From 6c39ec6d05467457c590ec93ad98c179be6618af Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Mon, 14 Sep 2020 01:31:01 +0100 Subject: [PATCH] @@@ version hash --- Makefile.am | 46 +++- dump-runlisp-image.c | 655 ++++++++++++++++++++++++++++++++++++--------------- lib.c | 24 +- lib.h | 22 +- runlisp.c | 9 +- 5 files changed, 537 insertions(+), 219 deletions(-) diff --git a/Makefile.am b/Makefile.am index c2f643a..e39d9bd 100644 --- a/Makefile.am +++ b/Makefile.am @@ -54,6 +54,18 @@ man_MANS += runlisp.1 doc_DATA += runlisp.pdf EXTRA_DIST += runlisp.1.in +noinst_PROGRAMS += old-runlisp +old_runlisp_SOURCES = old-runlisp.c +old_runlisp_LDADD = librunlisp.a + +noinst_PROGRAMS += toy +toy_SOURCES = toy.c +toy_LDADD = librunlisp.a + +noinst_PROGRAMS += hash +hash_SOURCES = hash.c +hash_LDADD = librunlisp.a + ###-------------------------------------------------------------------------- ### Additional machinery. @@ -108,41 +120,65 @@ v_dump = $(v_dump_@AM_V@) v_dump_ = $(v_dump_@AM_DEFAULT_V@) v_dump_0 = @echo " DUMP $@"; +IMAGES = +noinst_DATA += $(IMAGES) + if DUMP_SBCL -image_DATA += sbcl+asdf.core +IMAGES += sbcl+asdf.core CLEANFILES += sbcl+asdf.core sbcl+asdf.core: dump-runlisp-image runlisp-base.conf $(DUMP_RUNLISP_IMAGE) sbcl endif if DUMP_CCL -image_DATA += ccl+asdf.image +IMAGES += ccl+asdf.image CLEANFILES += ccl+asdf.image ccl+asdf.image: dump-runlisp-image runlisp-base.conf $(DUMP_RUNLISP_IMAGE) ccl endif if DUMP_CLISP -image_DATA += clisp+asdf.mem +IMAGES += clisp+asdf.mem CLEANFILES += clisp+asdf.mem clisp+asdf.mem: dump-runlisp-image runlisp-base.conf $(DUMP_RUNLISP_IMAGE) clisp endif if DUMP_ECL -image_SCRIPTS += ecl+asdf +IMAGES += ecl+asdf CLEANFILES += ecl+asdf ecl+asdf: dump-runlisp-image runlisp-base.conf dump-ecl $(DUMP_RUNLISP_IMAGE) -odata-dir=$(srcdir) ecl endif if DUMP_CMUCL -image_DATA += cmucl+asdf.core +IMAGES += cmucl+asdf.core CLEANFILES += cmucl+asdf.core cmucl+asdf.core: dump-runlisp-image runlisp-base.conf $(DUMP_RUNLISP_IMAGE) cmucl endif +install-data-hook:: + mkdir -p $(DESTDIR)$(imagedir) + set -e; for i in $(IMAGES); do \ + j=$$(readlink $$i); \ + cp $$j $(DESTDIR)$(imagedir)/$$j.new && \ + mv $(DESTDIR)$(imagedir)/$$j.new \ + $(DESTDIR)$(imagedir)/$$j; \ + ln -sf $$j $(DESTDIR)$(imagedir)/$$i; \ + done + +uninstall-hook:: + set -e; for i in $(IMAGES); do \ + if j=$$(readlink $(DESTDIR)$(imagedir)/$$i); then \ + case $$j in \ + $$i-*[!0-9a-f]) ;; \ + $$i-*) rm -f $(DESTDIR)$(imagedir)/$$j ;; \ + esac; \ + fi; \ + rm -f $(DESTDIR)$(imagedir)/$$i; \ + done + ###-------------------------------------------------------------------------- ### Other subdirectories. diff --git a/dump-runlisp-image.c b/dump-runlisp-image.c index 50bfb3f..7bd9eba 100644 --- a/dump-runlisp-image.c +++ b/dump-runlisp-image.c @@ -23,7 +23,7 @@ * along with Runlisp. If not, see . */ -/*----- Header files ---------------------------------------------------------*/ +/*----- Header files ------------------------------------------------------*/ #include "config.h" @@ -49,6 +49,7 @@ #include "common.h" #include "lib.h" #include "mdwopt.h" +#include "sha256.h" /*----- Static data -------------------------------------------------------*/ @@ -69,10 +70,9 @@ struct linebuf { /* 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 }; @@ -80,13 +80,16 @@ enum { 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) @@ -94,10 +97,10 @@ struct 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' */ @@ -124,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'. @@ -419,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; @@ -456,49 +485,112 @@ 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 ----------------------------------------------------*/ +/* Record the SZ-byte leafname at P as being legitimate, so that it doesn't + * get junked. + */ +static void notice_filename(const char *p, size_t sz) +{ + struct treap_node *node; + struct treap_path path; + + node = treap_probe(&good, p, sz, &path); + if (!node) { + node = xmalloc(sizeof(*node)); + treap_insert(&good, &path, node, p, sz); + } +} + +/* There are basically two kinds of jobs. + * + * An `internal' job -- state `JST_INTERN' -- can be handled entirely within + * this process. Internal jobs have trivial lifecycles: they're created, put + * on a queue, executed, and thrown away. Jobs are executed when some code + * decides to walk the appropriate queue and do the work. As a result, they + * don't need to have distinctive states: `JST_INTERN' only exists to + * distinguish internal jobs from active ones if they somehow manage to end + * up in the external-job machinery. + * + * External jobs all work in basically the same way: we fork and exec a + * sequence of subprocess to do the work. The majority of handling external + * jobs is in the care and feeding of these subprocesses, so they end up on + * various lists primarily concerned with the state of the subprocesses, and + * the progress of the job through its sequence of subprocesses is recorded + * in the job's `st' field. + * + * External jobs have a comparatively complicated lifecycle. + * + * * Initially, the job is on the `ready' queue by `add_job'. It has no + * child process or log file. + * + * * At some point, `start_jobs' decides to start this job up: a log file + * is created (if the job doesn't have one already), a child process is + * forked, and pipes are set up to capture the child's output. It gets + * moved to the `run' list (which is not maintained in any particular + * order). Jobs on the `run' list participate in the main select(2) + * loop. + * + * * When the job's child process dies and the pipes capturing its output + * streams finally dry up, the job is considered finished. What happens + * next depends on its state: either it gets updated somehow, and pushed + * back onto the end of the `ready' queue so that another child can be + * started, or the job is finished and dies. + * + * The counter `nrun' counts the number of actually running jobs, i.e., those + * with living child processes. This doesn't simply count the number of jobs + * on the `run' list: remember that the latter also contains jobs whose child + * has died, but whose output has not yet been collected. + */ + /* Consider a Lisp system description and maybe add a job to the right queue. * * The Lisp system is described by the configuration section SECT. Most of @@ -550,13 +642,15 @@ static void add_job(unsigned f, struct config_section *sect) { 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. */ @@ -584,7 +678,8 @@ static void add_job(unsigned f, struct config_section *sect) * 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; @@ -602,13 +697,14 @@ static void add_job(unsigned f, struct config_section *sect) 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, 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 @@ -619,49 +715,90 @@ static void add_job(unsigned f, struct config_section *sect) * 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, "", "${@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. */ - 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, "", "${@image-new}"); - imgout = - config_subst_string_alloc(&config, sect, "", "${@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 @@ -669,26 +806,32 @@ static void add_job(unsigned f, struct config_section *sect) * 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. @@ -716,9 +859,12 @@ static void release_job(struct job *job) 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); @@ -727,12 +873,16 @@ static void release_job(struct job *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. @@ -764,16 +914,115 @@ 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 (rename(job->imgnew, job->imghash)) { + fprintf(job->log, "%-13s > failed to rename Lisp `%s' " + "output image `%s' to `%s': %s", + JOB_NAME(job), JOB_NAME(job), + job->imgnew, job->imghash, strerror(errno)); + ok = 0; break; + } + + /* Determine the basename of the final image. */ + p = strrchr(job->imghash, '/'); if (p) p++; else p = job->imghash; + + /* Build the symlink. Start by setting the link in the staging path, + * and then rename, in order to ensure continuity. + */ + if (unlink(job->imgnewlink) && errno != ENOENT) { + bad("failed to clear Lisp `%s' link staging path `%s': %s", + JOB_NAME(job), job->imgnewlink, strerror(errno)); + break; + } + if (symlink(p, job->imgnewlink)) { + bad("failed to create Lisp `%s' image link `%s': %s", + JOB_NAME(job), job->imgnewlink, strerror(errno)); + break; + } + if (rename(job->imgnewlink, job->imglink)) { + bad("failed to rename Lisp `%s' image link `%s' to `%s': %s", + JOB_NAME(job), job->imgnewlink, job->imglink, strerror(errno)); + break; + } + if (job->oldimg && STRCMP(job->oldimg, !=, job->imghash) && + unlink(job->oldimg) && errno != ENOENT) { + if (verbose >= 1) + moan("failed to delete old Lisp `%s' image `%s': %s", + JOB_NAME(job), job->oldimg, strerror(errno)); + } + + /* 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 @@ -794,13 +1043,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; @@ -815,16 +1065,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. */ @@ -833,11 +1080,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); } @@ -849,6 +1095,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 @@ -860,44 +1107,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; + /* 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 @@ -915,14 +1182,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 @@ -943,15 +1211,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: @@ -985,8 +1252,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. @@ -1003,10 +1269,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 @@ -1025,31 +1287,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) { - 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); } } } } @@ -1234,13 +1489,15 @@ 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) @@ -1248,10 +1505,24 @@ int main(int argc, char *argv[]) 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(); @@ -1370,24 +1641,26 @@ int main(int argc, char *argv[]) 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) + 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)); diff --git a/lib.c b/lib.c index 36751ab..4f93285 100644 --- a/lib.c +++ b/lib.c @@ -1061,27 +1061,30 @@ struct config_var *config_find_var_n(struct config *conf, /* Set variable NAME to VALUE in SECT, with associated flags F. * * The names are null-terminated. The flags are variable flags: see `struct - * config_var' for details. + * config_var' for details. Returns the variable. * * If the variable is already set and has the `CF_OVERRIDE' flag, then this * function does nothing unless `CF_OVERRIDE' is /also/ set in F. */ -void config_set_var(struct config *conf, struct config_section *sect, - unsigned f, const char *name, const char *value) +struct config_var *config_set_var(struct config *conf, + struct config_section *sect, + unsigned f, + const char *name, const char *value) { - config_set_var_n(conf, sect, f, - name, strlen(name), - value, strlen(value)); + return (config_set_var_n(conf, sect, f, + name, strlen(name), + value, strlen(value))); } /* As `config_set_var', except that the variable NAME and VALUE have explicit * lengths (NAMELEN and VALUELEN, respectively) rather than being null- * terminated. */ -void config_set_var_n(struct config *conf, struct config_section *sect, - unsigned f, - const char *name, size_t namelen, - const char *value, size_t valuelen) +struct config_var *config_set_var_n(struct config *conf, + struct config_section *sect, + unsigned f, + const char *name, size_t namelen, + const char *value, size_t valuelen) { struct config_var *var = config_find_var_n(conf, sect, CF_CREAT, name, namelen); @@ -1089,6 +1092,7 @@ void config_set_var_n(struct config *conf, struct config_section *sect, if (var->f&~f&CF_OVERRIDE) return; free(var->val); var->val = xstrndup(value, valuelen); var->n = valuelen; var->f = f; + return (var); } /* Initialize I to iterate over the variables directly defined in SECT. */ diff --git a/lib.h b/lib.h index e7db07c..9bf07d9 100644 --- a/lib.h +++ b/lib.h @@ -108,6 +108,7 @@ #define CTYPE_HACK(func, ch) (func((unsigned char)(ch))) #define ISSPACE(ch) CTYPE_HACK(isspace, ch) #define ISALNUM(ch) CTYPE_HACK(isalnum, ch) +#define ISXDIGIT(ch) CTYPE_HACK(isxdigit, ch) #define TOLOWER(ch) CTYPE_HACK(tolower, ch) #define TOUPPER(ch) CTYPE_HACK(toupper, ch) @@ -621,23 +622,28 @@ extern struct config_var *config_find_var_n(struct config */*conf*/, * the NAME rather than null-termination. */ -extern void config_set_var(struct config */*conf*/, - struct config_section */*sect*/, unsigned /*f*/, - const char */*name*/, const char */*value*/); +extern struct config_var *config_set_var(struct config */*conf*/, + struct config_section */*sect*/, + unsigned /*f*/, + const char */*name*/, + const char */*value*/); /* Set variable NAME to VALUE in SECT, with associated flags F. * * The names are null-terminated. The flags are variable flags: see - * `struct config_var' for details. + * `struct config_var' for details. Returns the variable. * * If the variable is already set and has the `CF_OVERRIDE' flag, * then this function does nothing unless `CF_OVERRIDE' is /also/ set * in F. */ -extern void config_set_var_n(struct config */*conf*/, - struct config_section */*sect*/, unsigned /*f*/, - const char */*name*/, size_t /*namelen*/, - const char */*value*/, size_t /*valuelen*/); +extern struct config_var *config_set_var_n(struct config */*conf*/, + struct config_section */*sect*/, + unsigned /*f*/, + const char */*name*/, + size_t /*namelen*/, + const char */*value*/, + size_t /*valuelen*/); /* As `config_set_var', except that the variable NAME and VALUE have * explicit lengths (NAMELEN and VALUELEN, respectively) rather than * being null- terminated. diff --git a/runlisp.c b/runlisp.c index b2708d7..65741ad 100644 --- a/runlisp.c +++ b/runlisp.c @@ -495,11 +495,10 @@ int main(int argc, char *argv[]) /* If we're in eval mode, then find the `eval.lisp' script. */ if (!script) - script = config_subst_string_alloc - (&config, common, "", - "${@ENV:RUNLISP_EVAL?" - "${@CONFIG:eval-script?" - "${@data-dir}/eval.lisp}}"); + script = config_subst_string_alloc(&config, common, "", + "${@ENV:RUNLISP_EVAL?" + "${@CONFIG:eval-script?" + "${@data-dir}/eval.lisp}}"); /* We now have the script name, so publish it for `uiop'. * -- 2.11.0