* along with Runlisp. If not, see <https://www.gnu.org/licenses/>.
*/
-/*----- Header files ---------------------------------------------------------*/
+/*----- Header files ------------------------------------------------------*/
#include "config.h"
#include "common.h"
#include "lib.h"
#include "mdwopt.h"
+#include "sha256.h"
/*----- Static data -------------------------------------------------------*/
/* Job-state constants. */
enum {
- JST_READY, /* not yet started */
- JST_DELETE, /* just delete the image file */
- 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 */
- unsigned op; /* operation (`JOP_...') */
- 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)
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 by state */
- *job_ready, **job_ready_tail = &job_ready, /* some have tail pointers... */
- *job_delete, **job_delete_tail = &job_delete,
- *job_run, *job_dead; /* ... and some don't */
+static struct job /* lists of jobs */
+ *job_ready, **job_ready_tail = &job_ready, /* queue of jobs to start */
+ *job_delete, **job_delete_tail = &job_delete, /* queue of delete jobs */
+ *job_run; /* list of active jobs */
static unsigned nrun, maxrun = 1; /* running and maximum job counts */
static int rc = 0; /* code that we should return */
static int nullfd; /* file descriptor for `/dev/null' */
static 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
* 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 ----------------------------------------------------*/
+/* 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
{
const char *name;
struct job *job, ***tail;
- struct treap_path path, jobpath;
- struct config_var *dumpvar, *cmdvar, *imgvar;
- struct treap_node *n;
- struct dstr d = DSTR_INIT;
- struct argv av = ARGV_INIT;
- char *imgnew = 0, *imgout = 0;
+ struct treap_path jobpath;
+ struct config_var *dumpvar, *runvar, *imgvar;
+ struct dstr d = DSTR_INIT, dd = DSTR_INIT;
+ struct argv av_version = ARGV_INIT, av_dump = ARGV_INIT;
+ struct stat st;
+ char *imgnewlink = 0, *imglink = 0, *oldimg = 0, *p;
+ unsigned jst;
size_t i, len;
+ ssize_t n;
unsigned fef;
/* We'll want the section's name for all sorts of things. */
* it can't be dumped then we won't know what file to delete! So we have
* no choice.
*/
- if (!config_find_var(&config, sect, CF_INHERIT, "run-script")) {
+ 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;
dumpvar = config_find_var(&config, sect, CF_INHERIT, "dump-image");
if (!dumpvar)
lose("variable `dump-image' not defined for Lisp `%s'", name);
- cmdvar = config_find_var(&config, sect, CF_INHERIT, "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)
+ /* 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
* diagnostics.)
*/
if ((f&JF_CHECKINST) && (flags&AF_CHECKINST)) {
- dstr_reset(&d);
fef = (verbose >= 3 ? FEF_VERBOSE : 0);
- config_subst_var(&config, sect, cmdvar, &d);
- if (!found_in_path_p(d.p, fef)) {
+ if (!found_in_path_p(av_version.v[0], fef)) {
if (verbose >= 3)
moan("skipping Lisp `%s': can't find Lisp command `%s'",
- name, d.p);
+ name, av_version.v[0]);
goto end;
}
- if (STRCMP(d.p, !=, av.v[0]) && !found_in_path_p(av.v[0], fef)) {
+ 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.v[0], d.p);
+ av_dump.v[0], d.p);
goto end;
}
}
- /* If we're supposed to, then notice that this is the name of a good Lisp
- * image.
+ /* Collect the output image file names. */
+ imglink =
+ config_subst_string_alloc(&config, sect, "<internal>", "${@image-link}");
+ imgnewlink =
+ config_subst_string_alloc(&config, sect,
+ "<internal>", "${@image-newlink}");
+
+ /* Determine the image link basename. If necessary, record it so that it
+ * doesn't get junked.
*/
- if (f&JF_NOTICE) {
- dstr_reset(&d); config_subst_var(&config, sect, imgvar, &d);
- n = treap_probe(&good, d.p, d.len, &path);
- if (!n) {
- n = xmalloc(sizeof(*n));
- treap_insert(&good, &path, n, d.p, d.len);
- }
- }
+ dstr_reset(&dd); config_subst_var(&config, sect, imgvar, &dd);
+ if (f&JF_NOTICE) notice_filename(dd.p, dd.len);
- /* 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}");
+ /* 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 ((f&JF_CHECKEXIST) && !(flags&AF_FORCE)) {
- if (!access(imgout, F_OK)) {
- if (verbose >= 3)
- moan("skipping Lisp `%s': image `%s' already exists", name, imgout);
- f = (f&~JMASK_QUEUE) | JQ_NONE;
+ 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
* free it during cleanup.)
*/
switch (f&JMASK_QUEUE) {
- case JQ_NONE: tail = 0; break;
- case JQ_READY: tail = &job_ready_tail; break;
- case JQ_DELETE: tail = &job_delete_tail; break;
+ 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->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;
+ 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.
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);
/* 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;
+ /* Figure out what to do. */
+ switch (job->st) {
+ case JST_VERSION: av = &job->av_version; break;
+ case JST_DUMP: av = &job->av_dump; break;
+ default: assert(0);
+ }
+
/* If we're not actually going to do anything, now is the time to not do
- * that.
+ * that. We should do the version-hashing step unconditionally.
*/
- if (flags&AF_DRYRUN) {
- if (try_exec(&job->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;
+ 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);
}
- /* 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;
- }
+ /* Do one-time setup for external jobs. */
+ if (!job->log) {
- /* 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 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) {
- if (job->out.fd >= 0 && FD_ISSET(job->out.fd, &fd_in))
- prefix_lines(job, &job->out, '|');
- if (job->err.fd >= 0 && FD_ISSET(job->err.fd, &fd_in))
- prefix_lines(job, &job->err, '*');
- }
-
- /* Finally, clear away any dead jobs once we've collected all their
- * output.
+ /* Collect output from running jobs, and clear away any dead jobs once
+ * we've collected all their output.
*/
- for (link = &job_dead, job = *link; job; job = next) {
+ 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, '*');
+ 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 [-RUadfinqrv] [+RUdfinr] [-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\
-R, --remove-other Delete image files for other Lisp systems.\n\
-U, --remove-unknown Delete unrecognized files in image dir.\n\
-a, --all-configured Select all configured implementations.\n\
- -d, --cleanup Delete images which are no longer wanted.\n\
-f, --force Dump images even if they already exist.\n\
-i, --check-installed Check Lisp systems exist before dumping.\n\
-j, --jobs=NJOBS Run up to NJOBS jobs in parallel.\n\
/* Initial setup. */
set_progname(argv[0]);
init_config();
+ srand(time(0));
/* Parse the options. */
optprog = (/*unconst*/ char *)progname;
break
for (;;) {
- i = mdwopt(argc - 1, argv + 1, "hVO:R+U+ac:d+f+i+j:n+o:qr+v", 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) {
* 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)
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();
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->imgout);
+ JOB_NAME(job), job->oldimg);
} else {
if (verbose >= 2)
- moan("deleting `%s' image `%s' (dry run)",
- JOB_NAME(job), job->imgout);
- if (unlink(job->imgout) && errno != ENOENT)
+ 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->imgout, strerror(errno));
+ JOB_NAME(job), job->oldimg, strerror(errno));
}
}
/* Finally, maybe delete all of the junk files in the image directory. */
if (flags&AF_JUNK) {
- if (!out) {
- var = config_find_var(&config, builtin, CF_INHERIT, "@image-dir");
- assert(var); out = config_subst_var_alloc(&config, builtin, var);
- }
dir = opendir(out);
if (!dir)
lose("failed to open image directory `%s': %s", out, strerror(errno));
~mdw / runlisp / blobdiff