#include "common.h"
#include "lib.h"
#include "mdwopt.h"
+#include "sha256.h"
/*----- Static data -------------------------------------------------------*/
/* 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
};
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' */
#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 --------------------------------------------------------*/
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'.
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
+ * using `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;
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);
+ if (verbose >= 3) moan("noticed non-junk file `%.*s'", (int)sz, p);
+ }
+}
+
+/* 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.
*
- * 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.
+ * * `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.)
*
- * 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.)
+ * * `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 JF_QUIET 1u
-static void add_job(struct job ***tail_inout, unsigned f,
- const char *name, size_t len)
+#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,
+ config_subst_string_alloc
+ (&config, sect, "<internal>",
+ "?${lisp-version?(lisp-implementation-version)}"));
+ config_subst_split_var(&config, sect, dumpvar, &av_dump);
+ if (!av_dump.n)
lose("empty `dump-image' command for Lisp implementation `%s'", name);
/* If we're supposed to check that the Lisp exists before proceeding then
* 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, "<internal>", "${@image-new}");
- imgout =
- config_subst_string_alloc(&config, sect, "<internal>", "${@image-out}");
+ imglink =
+ config_subst_string_alloc(&config, sect, "<internal>", "${@image-link}");
+ imgnewlink =
+ config_subst_string_alloc(&config, sect,
+ "<internal>", "${@image-newlink}");
+
+ /* Determine the image link basename. If necessary, record it so that it
+ * doesn't get junked.
+ */
+ dstr_reset(&dd); config_subst_var(&config, sect, imgvar, &dd);
+ if (f&JF_NOTICE) notice_filename(dd.p, dd.len);
+
+ /* Fill in the directory name for the output image. */
+ dstr_reset(&d);
+ p = strrchr(imglink, '/');
+ if (p) dstr_putm(&d, imglink, p + 1 - imglink);
- /* 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.
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.
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 advances 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,
+ "<internal>", "${@image-out}");
+ job->imgnew =
+ config_subst_string_alloc(&config, job->sect,
+ "<internal>", "${@image-new}");
+
+ /* Determine the basename of the final image. */
+ p = strrchr(job->imghash, '/'); if (p) p++; else p = job->imghash;
+
+ /* Inspect the current link pointer to see if we have the right
+ * version.
+ */
+ if (!(flags&AF_FORCE) &&
+ job->oldimg &&
+ STRCMP(job->oldimg, ==, job->imghash) &&
+ !access(job->oldimg, F_OK)) {
+ if (verbose >= 2)
+ moan("Lisp `%s' image `%s' already up-to-date",
+ JOB_NAME(job), job->imghash);
+ break;
+ }
+
+ /* Make sure that there's a clear space for the new image to be
+ * written.
+ */
+ if (!(flags&AF_DRYRUN) && unlink(job->imgnew) && errno != ENOENT) {
+ bad("failed to clear Lisp `%s' image staging path `%s': %s",
+ JOB_NAME(job), job->imgnew, strerror(errno));
+ break;
+ }
+
+ /* If we're still here then we've decided to dump a new image. Update
+ * the job state, and put it back on the run queue.
+ */
+ config_subst_split_var(&config, job->sect,
+ job->dumpvar, &job->av_dump);
+ assert(job->av_dump.n);
+ job->st = JST_DUMP;
+ *job_ready_tail = job; job_ready_tail = &job->next; job->next = 0;
+ job = 0;
+ break;
+
+ case JST_DUMP:
+ /* We've finished dumping a custom image. It's time to apply the
+ * finishing touches.
+ */
+
+ /* Rename the image into place. If this fails, blame it on the dump
+ * job, because the chances are good that it failed to produce the
+ * image properly.
+ */
+ if (verbose >= 3)
+ moan("rename completed Lisp `%s' image `%s' to `%s'",
+ JOB_NAME(job), job->imgnew, job->imghash);
+ if (rename(job->imgnew, job->imghash)) {
+ fprintf(job->log, "%-13s > failed to rename Lisp `%s' "
+ "output image `%s' to `%s': %s",
+ JOB_NAME(job), JOB_NAME(job),
+ job->imgnew, job->imghash, strerror(errno));
+ ok = 0; break;
+ }
+
+ /* Notice the image so that it doesn't get junked. */
+ if (flags&AF_JUNK) {
+ p = strrchr(job->imghash, '/'); if (p) p++; else p = job->imghash;
+ notice_filename(p, strlen(p));
+ }
+
+ /* Determine the basename of the final image. */
+ p = strrchr(job->imghash, '/'); if (p) p++; else p = job->imghash;
+
+ /* Build the symlink. Start by setting the link in the staging path,
+ * and then rename, in order to ensure continuity.
+ */
+ if (unlink(job->imgnewlink) && errno != ENOENT) {
+ bad("failed to clear Lisp `%s' link staging path `%s': %s",
+ JOB_NAME(job), job->imgnewlink, strerror(errno));
+ break;
+ }
+ if (verbose >= 3)
+ moan("establish Lisp `%s' image link `%s' referring to `%s'",
+ JOB_NAME(job), job->imglink, job->imghash);
+ if (symlink(p, job->imgnewlink)) {
+ bad("failed to create Lisp `%s' image link `%s': %s",
+ JOB_NAME(job), job->imgnewlink, strerror(errno));
+ break;
+ }
+ if (rename(job->imgnewlink, job->imglink)) {
+ bad("failed to rename Lisp `%s' image link `%s' to `%s': %s",
+ JOB_NAME(job), job->imgnewlink, job->imglink, strerror(errno));
+ break;
+ }
+ if (job->oldimg && STRCMP(job->oldimg, !=, job->imghash)) {
+ if (verbose >= 3)
+ moan("remove old Lisp `%s' image `%s'",
+ JOB_NAME(job), job->oldimg);
+ if (unlink(job->oldimg) && errno != ENOENT) {
+ if (verbose >= 1)
+ moan("failed to delete old Lisp `%s' image `%s': %s",
+ JOB_NAME(job), job->oldimg, strerror(errno));
+ }
+ }
+
+ /* I think we're all done. */
+ break;
+
+ default:
+ assert(0);
}
/* If the job failed and we're being quiet then write out the log that we
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;
/* 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. */
}
/* 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);
}
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
* 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
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
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:
* `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.
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
{ 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); }
}
}
}
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);
}
{
version(fp); fputc('\n', fp); usage(fp);
fputs("\n\
-Help options:\n\
+Help options\n\
-h, --help Show this help text and exit successfully.\n\
-V, --version Show version number and exit successfully.\n\
\n\
-Diagnostics:\n\
+Diagnostics\n\
-n, --dry-run Don't run run anything (useful with `-v').\n\
-q, --quiet Don't print warning messages.\n\
-v, --verbose Print informational messages (repeatable).\n\
\n\
-Configuration:\n\
+Configuration\n\
-c, --config-file=CONF Read configuration from CONF (repeatable).\n\
-o, --set-option=[SECT:]VAR=VAL Set configuration variable (repeatable).\n\
\n\
-Image dumping:\n\
+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[])
{
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' },
{ "dry-run", OPTF_NEGATE, 0, 'n' },
{ "set-option", OPTF_ARGREQ, 0, 'o' },
{ "quiet", 0, 0, 'q' },
+ { "remove-image", OPTF_NEGATE, 0, 'r' },
{ "verbose", 0, 0, 'v' },
{ 0, 0, 0, 0 }
};
/* Initial setup. */
set_progname(argv[0]);
init_config();
+ srand(time(0));
/* Parse the options. */
optprog = (/*unconst*/ char *)progname;
+
+#define FLAGOPT(ch, f) \
+ case ch: \
+ flags |= f; \
+ break; \
+ case ch | OPTF_NEGATED: \
+ flags &= ~f; \
+ break
+
for (;;) {
- i = mdwopt(argc - 1, argv + 1, "hVO: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;
}
}
- /* CHeck that everything worked. */
+#undef FLAGOPT
+
+ /* Check that everything worked. */
optind++;
if ((flags&AF_ALL) ? optind < argc : optind >= argc) flags |= AF_BOGUS;
if (flags&AF_BOGUS) { usage(stderr); exit(127); }
* 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);
}
~mdw / runlisp / blobdiff