3 * Dump custom Lisp images for faster script execution
5 * (c) 2020 Mark Wooding
8 /*----- Licensing notice --------------------------------------------------*
10 * This file is part of Runlisp, a tool for invoking Common Lisp scripts.
12 * Runlisp is free software: you can redistribute it and/or modify it
13 * under the terms of the GNU General Public License as published by the
14 * Free Software Foundation; either version 3 of the License, or (at your
15 * option) any later version.
17 * Runlisp is distributed in the hope that it will be useful, but WITHOUT
18 * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
19 * FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
22 * You should have received a copy of the GNU General Public License
23 * along with Runlisp. If not, see <https://www.gnu.org/licenses/>.
26 /*----- Header files ------------------------------------------------------*/
43 #include <sys/select.h>
54 /*----- Static data -------------------------------------------------------*/
56 /* The state required to break an output stream from a subprocess into lines
57 * so we can prefix them appropriately. Once our process starts, the `buf'
58 * points to a buffer of `MAXLINE' bytes. This is arranged as a circular
59 * buffer, containing `len' bytes starting at offset `off', and wrapping
60 * around to the start of the buffer if it runs off the end.
62 * The descriptor `fd' is reset to -1 after it's seen end-of-file.
65 int fd
; /* our file descriptor (or -1) */
66 char *buf
; /* line buffer, or null */
67 unsigned off
, len
; /* offset */
69 #define MAXLINE 16384u /* maximum acceptable line length */
71 /* Job-state constants. */
73 JST_INTERN
, /* not that kind of job */
74 JST_VERSION
, /* hashing the Lisp version number */
75 JST_DUMP
, /* dumping the custom image */
79 /* The state associated with an image-dumping job. */
81 struct treap_node _node
; /* treap intrusion */
82 struct job
*next
; /* next job in whichever list */
83 unsigned st
; /* job state (`JST_...') */
84 struct config_section
*sect
; /* the system-definition section */
85 struct config_var
*dumpvar
; /* the `dump-image' variable */
86 struct argv av_version
, av_dump
; /* argument vectors to execute */
87 char *imgnew
, *imghash
, *imgnewlink
, *imglink
; /* link and final outputs */
88 char *oldimg
; /* old image name */
89 FILE *log
; /* log output file (`stdout'?) */
90 pid_t kid
; /* process id of child (or -1) */
91 int exit
; /* exit status from child */
92 struct sha256_state h
; /* hash context for version */
93 struct linebuf out
, err
; /* line buffers for stdout, stderr */
95 #define JOB_NAME(job) TREAP_NODE_KEY(job)
96 #define JOB_NAMELEN(job) TREAP_NODE_KEYLEN(job)
98 static struct treap jobs
= TREAP_INIT
, /* Lisp systems seen so far */
99 good
= TREAP_INIT
; /* files ok to be in image dir */
100 static struct job
/* lists of jobs */
101 *job_ready
, **job_ready_tail
= &job_ready
, /* queue of jobs to start */
102 *job_delete
, **job_delete_tail
= &job_delete
, /* queue of delete jobs */
103 *job_run
; /* list of active jobs */
104 static unsigned nrun
, maxrun
= 1; /* running and maximum job counts */
105 static int rc
= 0; /* code that we should return */
106 static int nullfd
; /* file descriptor for `/dev/null' */
107 static const char *tmpdir
; /* temporary directory path */
109 static int sig_pipe
[2] = { -1, -1 }; /* pipe for reporting signals */
110 static sigset_t caught
, pending
; /* signals we catch; have caught */
111 static int sigloss
= -1; /* signal that caused us to lose */
113 static unsigned flags
= 0; /* flags for the application */
114 #define AF_BOGUS 0x0001u /* invalid comand-line syntax */
115 #define AF_SETCONF 0x0002u /* explicit configuration */
116 #define AF_DRYRUN 0x0004u /* don't actually do it */
117 #define AF_ALL 0x0008u /* dump all known Lisps */
118 #define AF_FORCE 0x0010u /* dump even if images exist */
119 #define AF_CHECKINST 0x0020u /* check Lisp exists before dump */
120 #define AF_REMOVE 0x0040u /* remove selected Lisp images */
121 #define AF_CLEAN 0x0080u /* remove other Lisp images */
122 #define AF_JUNK 0x0100u /* remove unrecognized files */
124 /*----- Miscellany --------------------------------------------------------*/
126 /* Report a (printf(3)-style) message MSG, and remember to fail later. */
127 static PRINTF_LIKE(1, 2) void bad(const char *msg
, ...)
128 { va_list ap
; va_start(ap
, msg
); vmoan(msg
, ap
); va_end(ap
); rc
= 127; }
130 /* Answer whether a string consists entirely of hex digits. */
131 static int hex_digits_p(const char *p
, size_t sz
)
135 for (l
= p
+ sz
; p
< l
; p
++) if (!ISXDIGIT(*p
)) return (0);
139 /*----- File utilities ----------------------------------------------------*/
141 /* Main recursive subroutine for `recursive_delete'.
143 * The string DD currently contains the pathname of a directory, without a
144 * trailing `/' (though there is /space/ for a terminating zero or whatever).
145 * Recursively delete all of the files and directories within it. Appending
146 * further text to DD is OK, but clobbering the characters which are there
147 * already isn't allowed.
149 static void recursive_delete_(struct dstr
*dd
)
155 /* Open the directory. */
156 dd
->p
[n
] = 0; dir
= opendir(dd
->p
);
158 lose("failed to open directory `%s' for cleanup: %s",
159 dd
->p
, strerror(errno
));
161 /* We'll need to build pathnames for the files inside the directory, so add
162 * the separating `/' character. Remember the length of this prefix
163 * because this is the point we'll be rewinding to for each filename we
168 /* Now go through each file in turn. */
171 /* Get a filename. If we've run out then we're done. Skip the special
172 * `.' and `..' entries.
174 d
= readdir(dir
); if (!d
) break;
175 if (d
->d_name
[0] == '.' && (!d
->d_name
[1] ||
176 (d
->d_name
[1] == '.' && !d
->d_name
[2])))
179 /* Rewind the string offset and append the new filename. */
180 dd
->len
= n
; dstr_puts(dd
, d
->d_name
);
182 /* Try to delete it the usual way. If it was actually a directory then
183 * recursively delete it instead. (We could lstat(2) it first, but this
184 * should be at least as quick to identify a directory, and it'll save a
185 * lstat(2) call in the (common) case that it's not a directory.
188 else if (errno
== EISDIR
) recursive_delete_(dd
);
189 else lose("failed to delete file `%s': %s", dd
->p
, strerror(errno
));
192 /* We're done. Try to delete the directory. (It's possible that there was
193 * some problem with enumerating the directory, but we'll ignore that: if
194 * it matters then the directory won't be empty and the rmdir(2) will
200 lose("failed to delete directory `%s': %s", dd
->p
, strerror(errno
));
203 /* Recursively delete the thing named PATH. */
204 static void recursive_delete(const char *path
)
206 struct dstr d
= DSTR_INIT
;
207 dstr_puts(&d
, path
); recursive_delete_(&d
); dstr_release(&d
);
210 /* Configure a file descriptor FD.
212 * Set its nonblocking state to NONBLOCK and close-on-exec state to CLOEXEC.
213 * In both cases, -1 means to leave it alone, zero means to turn it off, and
214 * any other nonzero value means to turn it on.
216 static int configure_fd(const char *what
, int fd
, int nonblock
, int cloexec
)
220 if (nonblock
!= -1) {
221 fl
= fcntl(fd
, F_GETFL
); if (fl
< 0) goto fail
;
222 if (nonblock
) nfl
= fl
| O_NONBLOCK
;
223 else nfl
= fl
&~O_NONBLOCK
;
224 if (fl
!= nfl
&& fcntl(fd
, F_SETFL
, nfl
)) goto fail
;
228 fl
= fcntl(fd
, F_GETFD
); if (fl
< 0) goto fail
;
229 if (cloexec
) nfl
= fl
| FD_CLOEXEC
;
230 else nfl
= fl
&~FD_CLOEXEC
;
231 if (fl
!= nfl
&& fcntl(fd
, F_SETFD
, nfl
)) goto fail
;
237 bad("failed to configure %s descriptor: %s", what
, strerror(errno
));
241 /* Create a temporary directory and remember where we put it. */
242 static void set_tmpdir(void)
244 struct dstr d
= DSTR_INIT
;
248 /* Start building the path name. Remember the length: we'll rewind to
249 * here and try again if our first attempt doesn't work.
251 dstr_putf(&d
, "%s/runlisp.%d.", my_getenv("TMPDIR", "/tmp"), getpid());
254 /* Keep trying until it works. */
257 /* Build a complete name. */
258 d
.len
= n
; dstr_putf(&d
, "%d", rand());
260 /* Try to create the directory. If it worked, we're done. If it failed
261 * with `EEXIST' then we'll try again for a while, but give up it it
262 * doesn't look like we're making any progress. If it failed for some
263 * other reason then there's probably not much hope so give up.
265 if (!mkdir(d
.p
, 0700)) break;
266 else if (errno
!= EEXIST
)
267 lose("failed to create temporary directory `%s': %s",
268 d
.p
, strerror(errno
));
269 else if (++i
>= 32) {
270 d
.len
= n
; dstr_puts(&d
, "???");
271 lose("failed to create temporary directory `%s': too many attempts",
276 /* Remember the directory name. */
277 tmpdir
= xstrndup(d
.p
, d
.len
); dstr_release(&d
);
280 /*----- Signal handling ---------------------------------------------------*/
282 /* Forward reference into job management. */
283 static void reap_children(void);
285 /* Clean things up on exit.
287 * Currently this just means to delete the temporary directory if we've made
290 static void cleanup(void)
291 { if (tmpdir
) { recursive_delete(tmpdir
); tmpdir
= 0; } }
293 /* Check to see whether any signals have arrived, and do the sensible thing
296 static void check_signals(void)
302 /* Ensure exclusive access to the signal-handling machinery, drain the
303 * signal pipe, and take a copy of the set of caught signals.
305 sigprocmask(SIG_BLOCK
, &caught
, &old
);
306 pend
= pending
; sigemptyset(&pending
);
308 n
= read(sig_pipe
[0], buf
, sizeof(buf
));
309 if (!n
) lose("(internal) signal pipe closed!");
312 if (errno
!= EAGAIN
&& errno
!= EWOULDBLOCK
)
313 lose("failed to read signal pipe: %s", strerror(errno
));
314 sigprocmask(SIG_SETMASK
, &old
, 0);
316 /* Check for each signal of interest to us.
318 * Interrupty signals just set `sigloss' -- the `run_jobs' loop will know
319 * to unravel everything if this happens. If `SIGCHLD' happened, then
320 * check on job process status.
322 if (sigismember(&pend
, SIGINT
)) sigloss
= SIGINT
;
323 else if (sigismember(&pend
, SIGHUP
)) sigloss
= SIGHUP
;
324 else if (sigismember(&pend
, SIGTERM
)) sigloss
= SIGTERM
;
325 if (sigismember(&pend
, SIGCHLD
)) reap_children();
328 /* The actual signal handler.
330 * Set the appropriate signal bit in `pending', and a byte (of any value)
331 * down the signal pipe to wake up the select(2) loop.
333 static void handle_signal(int sig
)
338 /* Ensure exclusive access while we fiddle with the `caught' set. */
339 sigprocmask(SIG_BLOCK
, &caught
, &old
);
340 sigaddset(&pending
, sig
);
341 sigprocmask(SIG_SETMASK
, &old
, 0);
343 /* Wake up the select(2) loop. If this fails, there's not a lot we can do
346 DISCARD(write(sig_pipe
[1], &x
, 1));
349 /* Install our signal handler to catch SIG.
351 * If `SIGF_IGNOK' is set in F then don't trap the signal if it's currently
352 * ignored. (This is used for signals like `SIGINT', which usually should
353 * interrupt us; but if the caller wants us to ignore them, we should do as
356 * WHAT describes the signal, for use in diagnostic messages.
358 #define SIGF_IGNOK 1u
359 static void set_signal_handler(const char *what
, int sig
, unsigned f
)
361 struct sigaction sa
, sa_old
;
363 sigaddset(&caught
, sig
);
366 if (sigaction(sig
, 0, &sa_old
)) goto fail
;
367 if (sa_old
.sa_handler
== SIG_IGN
) return;
370 sa
.sa_handler
= handle_signal
;
371 sigemptyset(&sa
.sa_mask
);
372 sa
.sa_flags
= SA_NOCLDSTOP
;
373 if (sigaction(sig
, &sa
, 0)) goto fail
;
378 lose("failed to set %s signal handler: %s", what
, strerror(errno
));
381 /*----- Line buffering ----------------------------------------------------*/
383 /* Find the next newline in the line buffer BUF.
385 * The search starts at `BUF->off', and potentially covers the entire buffer
386 * contents. Set *LINESZ_OUT to the length of the line, in bytes. (Callers
387 * must beware that the text of the line may wrap around the ends of the
388 * buffer.) Return zero if we found a newline, or nonzero if the search
391 static int find_newline(struct linebuf
*buf
, size_t *linesz_out
)
395 if (buf
->off
+ buf
->len
<= MAXLINE
) {
396 /* The buffer contents is in one piece. Just search it. */
398 nl
= memchr(buf
->buf
+ buf
->off
, '\n', buf
->len
);
399 if (nl
) { *linesz_out
= (nl
- buf
->buf
) - buf
->off
; return (0); }
402 /* The buffer contents is in two pieces. We must search both of them. */
404 nl
= memchr(buf
->buf
+ buf
->off
, '\n', MAXLINE
- buf
->off
);
405 if (nl
) { *linesz_out
= (nl
- buf
->buf
) - buf
->off
; return (0); }
406 nl
= memchr(buf
->buf
, '\n', buf
->len
- (MAXLINE
- buf
->off
));
408 { *linesz_out
= (nl
- buf
->buf
) + (MAXLINE
- buf
->off
); return (0); }
414 /* Write a completed line out to the JOB's log file.
416 * The line starts at BUF->off, and continues for N bytes, not including the
417 * newline (which, in fact, might not exist at all). Precede the actual text
418 * of the line with the JOB's name, and the MARKER character, and follow it
419 * with the TAIL text (which should include an actual newline character).
421 static void write_line(struct job
*job
, struct linebuf
*buf
,
422 size_t n
, char marker
, const char *tail
)
424 fprintf(job
->log
, "%-13s %c ", JOB_NAME(job
), marker
);
425 if (buf
->off
+ n
<= MAXLINE
)
426 fwrite(buf
->buf
+ buf
->off
, 1, n
, job
->log
);
428 fwrite(buf
->buf
+ buf
->off
, 1, MAXLINE
- buf
->off
, job
->log
);
429 fwrite(buf
->buf
, 1, n
- (MAXLINE
- buf
->off
), job
->log
);
431 fputs(tail
, job
->log
);
434 /* Hash N bytes freshly added to the buffer BUF. */
435 static void hash_input(struct linebuf
*buf
, size_t n
, struct sha256_state
*h
)
437 size_t start
= (buf
->off
+ buf
->len
)%MAXLINE
;
439 if (start
+ n
<= MAXLINE
)
440 sha256_hash(h
, buf
->buf
+ start
, n
);
442 sha256_hash(h
, buf
->buf
+ start
, MAXLINE
- start
);
443 sha256_hash(h
, buf
->buf
, n
- (MAXLINE
- start
));
447 /* Collect output lines from JOB's process and write them to the log.
449 * Read data from BUF's file descriptor. Output complete (or overlong) lines
450 * usng `write_line'. On end-of-file, output any final incomplete line in
451 * the same way, close the descriptor, and set it to -1.
453 * As a rather unpleasant quirk, if the hash-state pointer H is not null,
454 * then also feed all the data received into it.
456 static void prefix_lines(struct job
*job
, struct linebuf
*buf
, char marker
,
457 struct sha256_state
*h
)
459 struct iovec iov
[2]; int niov
;
463 /* Read data into the buffer. This fancy dance with readv(2) is probably
466 * We can't have BUF->len = MAXLINE because we'd have flushed out a
467 * maximum-length buffer as an incomplete line last time.
469 assert(buf
->len
< MAXLINE
);
471 iov
[0].iov_base
= buf
->buf
+ buf
->len
;
472 iov
[0].iov_len
= MAXLINE
- buf
->len
;
474 } else if (buf
->off
+ buf
->len
>= MAXLINE
) {
475 iov
[0].iov_base
= buf
->buf
+ buf
->off
+ buf
->len
- MAXLINE
;
476 iov
[0].iov_len
= MAXLINE
- buf
->len
;
479 iov
[0].iov_base
= buf
->buf
+ buf
->off
+ buf
->len
;
480 iov
[0].iov_len
= MAXLINE
- (buf
->off
+ buf
->len
);
481 iov
[1].iov_base
= buf
->buf
;
482 iov
[1].iov_len
= buf
->off
;
485 n
= readv(buf
->fd
, iov
, niov
);
488 /* An error occurred. If there's no data to read after all then just
489 * move on. Otherwise we have a problem.
492 if (errno
== EAGAIN
|| errno
== EWOULDBLOCK
) return;
493 lose("failed to read job `%s' output stream: %s",
494 JOB_NAME(job
), strerror(errno
));
496 /* We've hit end-of-file. Close the stream, and write out any
497 * unterminated partial line.
500 close(buf
->fd
); buf
->fd
= -1;
502 write_line(job
, buf
, buf
->len
, marker
, " [missing final newline]\n");
504 /* We read some fresh data. Output any new complete lines. */
506 /* If we're supposed to hash data as it comes in then we should do that
509 if (h
) hash_input(buf
, n
, h
);
511 /* Include the new material in the buffer length, and write out any
512 * complete lines we find.
515 while (!find_newline(buf
, &linesz
)) {
516 write_line(job
, buf
, linesz
, marker
, "\n");
517 buf
->len
-= linesz
+ 1;
518 buf
->off
+= linesz
+ 1; if (buf
->off
>= MAXLINE
) buf
->off
-= MAXLINE
;
522 /* If there's nothing left then we might as well reset the buffer
523 * offset to the start of the buffer.
526 else if (buf
->len
== MAXLINE
) {
527 /* We've filled the buffer with stuff that's not a whole line. Flush
530 write_line(job
, buf
, MAXLINE
, marker
, " [...]\n");
531 buf
->off
= buf
->len
= 0;
536 /*----- Job management ----------------------------------------------------*/
538 /* Record the SZ-byte leafname at P as being legitimate, so that it doesn't
541 static void notice_filename(const char *p
, size_t sz
)
543 struct treap_node
*node
;
544 struct treap_path path
;
546 node
= treap_probe(&good
, p
, sz
, &path
);
548 node
= xmalloc(sizeof(*node
));
549 treap_insert(&good
, &path
, node
, p
, sz
);
553 /* There are basically two kinds of jobs.
555 * An `internal' job -- state `JST_INTERN' -- can be handled entirely within
556 * this process. Internal jobs have trivial lifecycles: they're created, put
557 * on a queue, executed, and thrown away. Jobs are executed when some code
558 * decides to walk the appropriate queue and do the work. As a result, they
559 * don't need to have distinctive states: `JST_INTERN' only exists to
560 * distinguish internal jobs from active ones if they somehow manage to end
561 * up in the external-job machinery.
563 * External jobs all work in basically the same way: we fork and exec a
564 * sequence of subprocess to do the work. The majority of handling external
565 * jobs is in the care and feeding of these subprocesses, so they end up on
566 * various lists primarily concerned with the state of the subprocesses, and
567 * the progress of the job through its sequence of subprocesses is recorded
568 * in the job's `st' field.
570 * External jobs have a comparatively complicated lifecycle.
572 * * Initially, the job is on the `ready' queue by `add_job'. It has no
573 * child process or log file.
575 * * At some point, `start_jobs' decides to start this job up: a log file
576 * is created (if the job doesn't have one already), a child process is
577 * forked, and pipes are set up to capture the child's output. It gets
578 * moved to the `run' list (which is not maintained in any particular
579 * order). Jobs on the `run' list participate in the main select(2)
582 * * When the job's child process dies and the pipes capturing its output
583 * streams finally dry up, the job is considered finished. What happens
584 * next depends on its state: either it gets updated somehow, and pushed
585 * back onto the end of the `ready' queue so that another child can be
586 * started, or the job is finished and dies.
588 * The counter `nrun' counts the number of actually running jobs, i.e., those
589 * with living child processes. This doesn't simply count the number of jobs
590 * on the `run' list: remember that the latter also contains jobs whose child
591 * has died, but whose output has not yet been collected.
594 /* Consider a Lisp system description and maybe add a job to the right queue.
596 * The Lisp system is described by the configuration section SECT. Most of
597 * the function is spent on inspecting this section for suitability and
598 * deciding what to do about it.
600 * The precise behaviour depends on F, which should be the bitwise-OR of a
601 * `JQ_...' constant and zero or more flags, as follows.
603 * * The bits covered by `JMASK_QUEUE' identify which queue the job should
604 * be added to if the section defines a cromulent Lisp system:
606 * -- `JQ_NONE' -- don't actually make a job at all;
607 * -- `JQ_READY' -- add the Lisp to the `job_ready' queue, so we'll; or
608 * -- `JQ_DELETE' -- add the Lisp to the `job_delete' queue.
610 * * `JF_PICKY': The user identified this Lisp system explicitly, so
611 * complain if the configuration section doesn't look right. This is
612 * clear if the caller is just enumerating all of the configuration
613 * sections: without this feature, we'd be checking everything twice,
614 * which (a) is inefficient, and -- more importantly -- (b) could lead to
615 * problems if the two checks are inconsistent.
617 * * `JF_CHECKINST': Ignore this Lisp if `AF_CHECKINST' is set and it's not
618 * actually installed. (This is usually set for `JQ_READY' calls, so
619 * that we don't try to dump Lisps which aren't there, but clear for
620 * `JQ_DELETE' calls so that we clear out Lisps which have gone away.)
622 * * `JF_CHECKEXIST': Ignore this Lisp if its image file already exists.
624 * * `JF_NOTICE': Record the Lisp's image basename in the `good' treap so
625 * that we can identify everything else we find in the image directory as
628 #define JMASK_QUEUE 3u /* which queue to add good Lisp to */
629 #define JQ_NONE 0u /* don't add to any queue */
630 #define JQ_READY 1u /* `job_ready' */
631 #define JQ_DELETE 2u /* `job_delete' */
632 #define JF_PICKY 4u /* lose if section isn't Lisp defn */
633 #define JF_CHECKINST 8u /* maybe check Lisp is installed */
634 #define JF_CHECKEXIST 16u /* skip if image already exists */
635 #define JF_NOTICE 32u /* record Lisp's image basename */
637 #define JADD_NAMED (JQ_READY | JF_PICKY | JF_CHECKINST)
638 #define JADD_DEFAULT (JQ_READY | JF_CHECKINST)
639 #define JADD_CLEANUP (JQ_DELETE)
640 #define JADD_NOTICE (JQ_NONE)
641 static void add_job(unsigned f
, struct config_section
*sect
)
644 struct job
*job
, ***tail
;
645 struct treap_path jobpath
;
646 struct config_var
*dumpvar
, *runvar
, *imgvar
;
647 struct dstr d
= DSTR_INIT
, dd
= DSTR_INIT
;
648 struct argv av_version
= ARGV_INIT
, av_dump
= ARGV_INIT
;
650 char *imgnewlink
= 0, *imglink
= 0, *oldimg
= 0, *p
;
656 /* We'll want the section's name for all sorts of things. */
657 name
= CONFIG_SECTION_NAME(sect
);
658 len
= CONFIG_SECTION_NAMELEN(sect
);
660 /* Check to see whether this Lisp system is already queued up.
662 * We'll get around to adding the new job node to the treap right at the
663 * end, so use a separate path object to keep track of where to put it.
665 job
= treap_probe(&jobs
, name
, len
, &jobpath
);
667 if ((f
&JF_PICKY
) && verbose
>= 1)
668 moan("ignoring duplicate Lisp `%s'", JOB_NAME(job
));
672 /* Check that the section defines a Lisp, and that it can be dumped.
674 * It's not obvious that this is right. Maybe there should be some
675 * additional flag so that we don't check dumpability if we're planning to
676 * delete the image. But it /is/ right: since the thing which tells us
677 * whether we can dump is that the section tells us the image's name, if
678 * it can't be dumped then we won't know what file to delete! So we have
681 runvar
= config_find_var(&config
, sect
, CF_INHERIT
, "run-script");
683 if (f
&JF_PICKY
) lose("unknown Lisp implementation `%s'", name
);
684 else if (verbose
>= 3) moan("skipping non-Lisp section `%s'", name
);
687 imgvar
= config_find_var(&config
, sect
, CF_INHERIT
, "image-file");
690 lose("Lisp implementation `%s' doesn't use custom images", name
);
691 else if (verbose
>= 3)
692 moan("skipping Lisp `%s': no custom image support", name
);
696 /* Check that the other necessary variables are present. */
697 dumpvar
= config_find_var(&config
, sect
, CF_INHERIT
, "dump-image");
699 lose("variable `dump-image' not defined for Lisp `%s'", name
);
701 /* Build the job's command lines. */
702 config_subst_split_var(&config
, sect
, runvar
, &av_version
);
704 lose("empty `run-script' command for Lisp implementation `%s'", name
);
705 argv_append(&av_version
, xstrdup("?(lisp-implementation-version)"));
706 config_subst_split_var(&config
, sect
, dumpvar
, &av_dump
);
708 lose("empty `dump-image' command for Lisp implementation `%s'", name
);
710 /* If we're supposed to check that the Lisp exists before proceeding then
711 * do that. There are /two/ commands to check: the basic Lisp command,
712 * /and/ the command to actually do the dumping, which might not be the
713 * same thing. (Be careful not to check the same command twice, though,
714 * because that would cause us to spam the user with redundant
717 if ((f
&JF_CHECKINST
) && (flags
&AF_CHECKINST
)) {
718 fef
= (verbose
>= 3 ? FEF_VERBOSE
: 0);
719 if (!found_in_path_p(av_version
.v
[0], fef
)) {
721 moan("skipping Lisp `%s': can't find Lisp command `%s'",
722 name
, av_version
.v
[0]);
725 if (STRCMP(av_version
.v
[0], !=, av_dump
.v
[0]) &&
726 !found_in_path_p(av_dump
.v
[0], fef
)) {
728 moan("skipping Lisp `%s': can't find dump command `%s'",
734 /* Collect the output image file names. */
736 config_subst_string_alloc(&config
, sect
, "<internal>", "${@image-link}");
738 config_subst_string_alloc(&config
, sect
,
739 "<internal>", "${@image-newlink}");
741 /* Determine the image link basename. If necessary, record it so that it
742 * doesn't get junked.
744 dstr_reset(&dd
); config_subst_var(&config
, sect
, imgvar
, &dd
);
745 if (f
&JF_NOTICE
) notice_filename(dd
.p
, dd
.len
);
747 /* Fill in the directory name for the output image. */
749 p
= strrchr(imglink
, '/');
750 if (p
) dstr_putm(&d
, imglink
, p
+ 1 - imglink
);
752 /* Inspect the existing image link if there is one, and record its
757 /* Read the link destination. The `lstat'/`readlink' two-step is
758 * suggested by the POSIX specification.
760 if (lstat(imglink
, &st
)) {
761 if (verbose
>= (errno
== ENOENT ?
3 : 1))
762 moan("failed to read metadata for Lisp `%s' image link `%s': %s",
763 name
, imglink
, strerror(errno
));
766 if (!S_ISLNK(st
.st_mode
)) {
768 moan("Lisp `%s' image link `%s' isn't a symbolic link",
772 dstr_ensure(&d
, st
.st_size
+ 1);
773 n
= readlink(imglink
, d
.p
+ d
.len
, d
.sz
- d
.len
);
775 moan("failed to read Lisp `%s' image link `%s': %s",
776 name
, imglink
, strerror(errno
));
779 if (n
== d
.sz
- d
.len
) continue;
781 /* Check that the link has the right form. (We don't want to delete the
782 * referent if it's not actually our image.)
784 * We expect the referent to look like ${image-file} followed by a hyphen
785 * and some hex digits.
788 STRNCMP(d
.p
+ d
.len
, !=, dd
.p
, dd
.len
) ||
789 d
.p
[d
.len
+ dd
.len
] != '-' ||
790 !hex_digits_p(d
.p
+ (d
.len
+ dd
.len
+ 1), n
- (dd
.len
+ 1))) {
792 moan("Lisp `%s' image link `%s' has unexpected referent `%s'",
797 /* OK, so it looks legit. Protect it from being junked. */
798 if (f
&JF_NOTICE
) notice_filename(d
.p
+ d
.len
, n
);
799 d
.p
[d
.len
+ n
] = 0; d
.len
+= n
;
800 oldimg
= xstrndup(d
.p
, d
.len
);
804 /* All preflight checks complete. Build the job and hook it onto the end
805 * of the list. (Steal the command-line vector so that we don't try to
806 * free it during cleanup.)
808 switch (f
&JMASK_QUEUE
) {
809 case JQ_NONE
: jst
= JST_INTERN
; tail
= 0; break;
810 case JQ_READY
: jst
= JST_VERSION
; tail
= &job_ready_tail
; break;
811 case JQ_DELETE
: jst
= JST_INTERN
; tail
= &job_delete_tail
; break;
814 job
= xmalloc(sizeof(*job
));
815 job
->st
= jst
; job
->sect
= sect
; job
->dumpvar
= dumpvar
;
816 job
->kid
= -1; job
->log
= 0;
817 job
->out
.fd
= -1; job
->out
.buf
= 0;
818 job
->err
.fd
= -1; job
->err
.buf
= 0;
819 job
->av_version
= av_version
; argv_init(&av_version
);
820 argv_init(&job
->av_dump
);
821 job
->imgnew
= 0; job
->imghash
= 0;
822 job
->imgnewlink
= imgnewlink
; imgnewlink
= 0;
823 job
->imglink
= imglink
; imglink
= 0;
824 job
->oldimg
= oldimg
; oldimg
= 0;
825 treap_insert(&jobs
, &jobpath
, &job
->_node
, name
, len
);
826 if (tail
) { **tail
= job
; *tail
= &job
->next
; }
829 /* All done. Cleanup time. */
830 for (i
= 0; i
< av_version
.n
; i
++) free(av_version
.v
[i
]);
831 for (i
= 0; i
< av_dump
.n
; i
++) free(av_dump
.v
[i
]);
832 free(imgnewlink
); free(imglink
); free(oldimg
);
833 dstr_release(&d
); dstr_release(&dd
);
834 argv_release(&av_version
); argv_release(&av_dump
);
837 /* As `add_job' above, but look the Lisp implementation up by name.
839 * The flags passed to `add_job' are augmented with `JF_PICKY' because this
840 * is an explicitly-named Lisp implementation.
842 static void add_named_job(unsigned f
, const char *name
, size_t len
)
844 struct config_section
*sect
;
846 sect
= config_find_section_n(&config
, 0, name
, len
);
847 if (!sect
) lose("unknown Lisp implementation `%.*s'", (int)len
, name
);
848 add_job(f
| JF_PICKY
, sect
);
851 /* Free the JOB and all the resources it holds.
853 * Close the pipes; kill the child process. Everything must go.
855 static void release_job(struct job
*job
)
860 if (job
->kid
> 0) kill(job
->kid
, SIGKILL
); /* ?? */
861 if (job
->log
&& job
->log
!= stdout
) fclose(job
->log
);
862 free(job
->imgnew
); free(job
->imghash
);
863 free(job
->imglink
); free(job
->imgnewlink
);
865 for (i
= 0; i
< job
->av_version
.n
; i
++) free(job
->av_version
.v
[i
]);
866 for (i
= 0; i
< job
->av_dump
.n
; i
++) free(job
->av_dump
.v
[i
]);
867 argv_release(&job
->av_version
); argv_release(&job
->av_dump
);
868 free(job
->out
.buf
); if (job
->out
.fd
>= 0) close(job
->out
.fd
);
869 free(job
->err
.buf
); if (job
->err
.fd
>= 0) close(job
->err
.fd
);
870 j
= treap_remove(&jobs
, JOB_NAME(job
), JOB_NAMELEN(job
)); assert(j
== job
);
874 /* Do all the necessary things when JOB finishes (successfully or not).
876 * Eventually the job is either freed (using `release_job'), or updated and
877 * stuffed back into the `job_run' queue. The caller is expected to have
878 * already unlinked the job from its current list.
880 static void finish_job(struct job
*job
)
884 struct dstr d
= DSTR_INIT
;
888 /* Start a final line to the job log describing its eventual fate.
890 * This is where we actually pick apart the exit status. Set `ok' if it
891 * actually succeeded, because that's all anything else cares about.
893 fprintf(job
->log
, "%-13s > ", JOB_NAME(job
));
894 if (WIFEXITED(job
->exit
)) {
895 if (!WEXITSTATUS(job
->exit
))
896 { fputs("completed successfully\n", job
->log
); ok
= 1; }
898 fprintf(job
->log
, "failed with exit status %d\n",
899 WEXITSTATUS(job
->exit
));
900 } else if (WIFSIGNALED(job
->exit
))
901 fprintf(job
->log
, "killed by signal %d (%s%s)", WTERMSIG(job
->exit
),
902 #if defined(HAVE_STRSIGNAL)
903 strsignal(WTERMSIG(job
->exit
)),
904 #elif defined(HAVE_DECL_SYS_SIGLIST)
905 sys_siglist
[WTERMSIG(job
->exit
)],
910 WCOREDUMP(job
->exit
) ?
"; core dumped" :
914 fprintf(job
->log
, "exited with incomprehensible status %06o\n",
917 /* What happens next depends on the state of the job. This is the main
918 * place which advanced the job state machine.
920 if (ok
) switch (job
->st
) {
923 /* We've retrieved the Lisp system's version string. */
925 /* Complete the hashing and convert to hex. */
926 hbuf
= (unsigned char *)buf
+ 32; sha256_done(&job
->h
, hbuf
);
927 for (i
= 0; i
< 8; i
++) sprintf(buf
+ 2*i
, "%02x", hbuf
[i
]);
929 moan("Lisp `%s' version hash = %s", JOB_NAME(job
), buf
);
931 /* Determine the final version-qualified name for the image. */
932 config_set_var(&config
, job
->sect
, CF_LITERAL
, "@hash", buf
);
934 config_subst_string_alloc(&config
, job
->sect
,
935 "<internal>", "${@image-out}");
937 config_subst_string_alloc(&config
, job
->sect
,
938 "<internal>", "${@image-new}");
940 /* Determine the basename of the final image. */
941 p
= strrchr(job
->imghash
, '/'); if (p
) p
++; else p
= job
->imghash
;
943 /* Inspect the current link pointer to see if we have the right
946 if (!(flags
&AF_FORCE
) &&
948 STRCMP(job
->oldimg
, ==, job
->imghash
) &&
949 !access(job
->oldimg
, F_OK
)) {
951 moan("Lisp `%s' image `%s' already up-to-date",
952 JOB_NAME(job
), job
->imghash
);
956 /* Make sure that there's a clear space for the new image to be
959 if (!(flags
&AF_DRYRUN
) && unlink(job
->imgnew
) && errno
!= ENOENT
) {
960 bad("failed to clear Lisp `%s' image staging path `%s': %s",
961 JOB_NAME(job
), job
->imgnew
, strerror(errno
));
965 /* If we're still here then we've decided to dump a new image. Update
966 * the job state, and put it back on the run queue.
968 config_subst_split_var(&config
, job
->sect
,
969 job
->dumpvar
, &job
->av_dump
);
970 assert(job
->av_dump
.n
);
972 *job_ready_tail
= job
; job_ready_tail
= &job
->next
; job
->next
= 0;
977 /* We've finished dumping a custom image. It's time to apply the
981 /* Rename the image into place. If this fails, blame it on the dump
982 * job, because the chances are good that it failed to produce the
986 moan("rename completed Lisp `%s' image `%s' to `%s'",
987 JOB_NAME(job
), job
->imgnew
, job
->imghash
);
988 if (rename(job
->imgnew
, job
->imghash
)) {
989 fprintf(job
->log
, "%-13s > failed to rename Lisp `%s' "
990 "output image `%s' to `%s': %s",
991 JOB_NAME(job
), JOB_NAME(job
),
992 job
->imgnew
, job
->imghash
, strerror(errno
));
996 /* Determine the basename of the final image. */
997 p
= strrchr(job
->imghash
, '/'); if (p
) p
++; else p
= job
->imghash
;
999 /* Build the symlink. Start by setting the link in the staging path,
1000 * and then rename, in order to ensure continuity.
1002 if (unlink(job
->imgnewlink
) && errno
!= ENOENT
) {
1003 bad("failed to clear Lisp `%s' link staging path `%s': %s",
1004 JOB_NAME(job
), job
->imgnewlink
, strerror(errno
));
1008 moan("establish Lisp `%s' image link `%s' referring to `%s'",
1009 JOB_NAME(job
), job
->imglink
, job
->imghash
);
1010 if (symlink(p
, job
->imgnewlink
)) {
1011 bad("failed to create Lisp `%s' image link `%s': %s",
1012 JOB_NAME(job
), job
->imgnewlink
, strerror(errno
));
1015 if (rename(job
->imgnewlink
, job
->imglink
)) {
1016 bad("failed to rename Lisp `%s' image link `%s' to `%s': %s",
1017 JOB_NAME(job
), job
->imgnewlink
, job
->imglink
, strerror(errno
));
1020 if (job
->oldimg
&& STRCMP(job
->oldimg
, !=, job
->imghash
)) {
1022 moan("remove old Lisp `%s' image `%s'",
1023 JOB_NAME(job
), job
->oldimg
);
1024 if (unlink(job
->oldimg
) && errno
!= ENOENT
) {
1026 moan("failed to delete old Lisp `%s' image `%s': %s",
1027 JOB_NAME(job
), job
->oldimg
, strerror(errno
));
1031 /* I think we're all done. */
1038 /* If the job failed and we're being quiet then write out the log that we
1041 if (!ok
&& verbose
< 2) {
1044 n
= fread(buf
, 1, sizeof(buf
), job
->log
);
1045 if (n
) fwrite(buf
, 1, n
, stdout
);
1046 if (n
< sizeof(buf
)) break;
1050 /* Also make a node to stderr about what happened. (Just to make sure
1051 * that we've gotten someone's attention.)
1053 if (!ok
) bad("failed to dump Lisp `%s'", JOB_NAME(job
));
1055 /* Finally free the job control block. */
1056 if (job
) release_job(job
);
1060 /* Called after `SIGCHLD': collect exit statuses and mark jobs as dead. */
1061 static void reap_children(void)
1069 /* Collect a child exit status. If there aren't any more then we're
1072 kid
= waitpid(0, &st
, WNOHANG
);
1073 if (kid
<= 0) break;
1075 /* Try to find a matching job. If we can't, then we should just ignore
1078 for (job
= job_run
; job
; job
= job
->next
)
1079 if (job
->kid
== kid
) goto found
;
1083 /* Mark the job as dead, and save its exit status. */
1084 job
->exit
= st
; job
->kid
= -1; nrun
--;
1087 /* If there was a problem with waitpid(2) then report it. */
1088 if (kid
< 0 && errno
!= ECHILD
)
1089 lose("failed to collect child process exit status: %s", strerror(errno
));
1092 /* Execute the handler for some JOB. */
1093 static NORETURN
void job_child(struct job
*job
, struct argv
*av
)
1096 moan("failed to run `%s': %s", av
->v
[0], strerror(errno
));
1100 /* Start up jobs while there are (a) jobs to run and (b) slots to run them
1103 static void start_jobs(void)
1105 struct dstr d
= DSTR_INIT
;
1106 int p_out
[2], p_err
[2];
1111 /* Keep going until either we run out of jobs, or we've got enough running
1114 while (job_ready
&& nrun
< maxrun
) {
1116 /* Set things up ready. If things go wrong, we need to know what stuff
1117 * needs to be cleaned up.
1119 job
= job_ready
; job_ready
= job
->next
;
1120 if (!job_ready
) job_ready_tail
= &job_ready
;
1121 p_out
[0] = p_out
[1] = p_err
[0] = p_err
[1] = -1;
1123 /* Figure out what to do. */
1125 case JST_VERSION
: av
= &job
->av_version
; break;
1126 case JST_DUMP
: av
= &job
->av_dump
; break;
1130 /* If we're not actually going to do anything, now is the time to not do
1131 * that. We should do the version-hashing step unconditionally.
1137 if (flags
&AF_DRYRUN
) {
1140 (verbose
>= 2 && !(flags
&AF_CHECKINST
)
1141 ? TEF_VERBOSE
: 0)))
1143 else if (verbose
>= 2)
1144 printf("%-13s > not dumping `%s' (dry run)\n",
1145 JOB_NAME(job
), JOB_NAME(job
));
1154 /* Do one-time setup for external jobs. */
1157 /* Make a temporary subdirectory for this job to use. */
1158 dstr_reset(&d
); dstr_putf(&d
, "%s/%s", tmpdir
, JOB_NAME(job
));
1159 if (mkdir(d
.p
, 0700)) {
1160 bad("failed to create working directory for job `%s': %s",
1161 JOB_NAME(job
), strerror(errno
));
1165 /* Create the job's log file. If we're being verbose then that's just
1166 * our normal standard output -- /not/ stderr: it's likely that users
1167 * will want to pipe this stuff through a pager or something, and
1168 * that'll be easier if we use stdout. Otherwise, make a file in the
1169 * temporary directory.
1174 dstr_puts(&d
, "/log"); job
->log
= fopen(d
.p
, "w+");
1176 lose("failed to open log file `%s': %s", d
.p
, strerror(errno
));
1180 /* Make the pipes to capture the child process's standard output and
1183 if (pipe(p_out
) || pipe(p_err
)) {
1184 bad("failed to create pipes for job `%s': %s",
1185 JOB_NAME(job
), strerror(errno
));
1188 if (configure_fd("job stdout pipe", p_out
[0], 1, 1) ||
1189 configure_fd("job stdout pipe", p_out
[1], 0, 1) ||
1190 configure_fd("job stderr pipe", p_err
[0], 1, 1) ||
1191 configure_fd("job stderr pipe", p_err
[1], 0, 1) ||
1192 configure_fd("log file", fileno(job
->log
), 1, 1))
1195 /* Initialize the output-processing structures ready for use. */
1196 if (job
->st
== JST_VERSION
) sha256_init(&job
->h
);
1197 job
->out
.buf
= xmalloc(MAXLINE
); job
->out
.off
= job
->out
.len
= 0;
1198 job
->out
.fd
= p_out
[0]; p_out
[0] = -1;
1199 job
->err
.buf
= xmalloc(MAXLINE
); job
->err
.off
= job
->err
.len
= 0;
1200 job
->err
.fd
= p_err
[0]; p_err
[0] = -1;
1202 /* Print a note to the top of the log. */
1203 dstr_reset(&d
); argv_string(&d
, av
);
1204 fprintf(job
->log
, "%-13s > starting %s\n", JOB_NAME(job
), d
.p
);
1206 /* Flush the standard output stream. (Otherwise the child might try to
1211 /* Spin up the child process. */
1214 bad("failed to fork process for job `%s': %s",
1215 JOB_NAME(job
), strerror(errno
));
1219 if (dup2(nullfd
, 0) < 0 ||
1220 dup2(p_out
[1], 1) < 0 ||
1221 dup2(p_err
[1], 2) < 0)
1222 lose("failed to juggle job `%s' file descriptors: %s",
1223 JOB_NAME(job
), strerror(errno
));
1227 /* Close the ends of the pipes that we don't need. Move the job into
1230 close(p_out
[1]); close(p_err
[1]);
1231 job
->kid
= kid
; job
->next
= job_run
; job_run
= job
; nrun
++;
1235 /* Clean up the wreckage if it didn't work. */
1236 if (p_out
[0] >= 0) close(p_out
[0]);
1237 if (p_out
[1] >= 0) close(p_out
[1]);
1238 if (p_err
[0] >= 0) close(p_err
[0]);
1239 if (p_err
[1] >= 0) close(p_err
[1]);
1243 /* All done except for some final tidying up. */
1247 /* Take care of all of the jobs until they're all done. */
1248 static void run_jobs(void)
1250 struct job
*job
, *next
, **link
;
1256 /* If there are jobs still to be started and we have slots to spare then
1257 * start some more up.
1261 /* If the queues are now all empty then we're done. (No need to check
1262 * `job_ready' here: `start_jobs' would have started them if `job_run'
1265 if (!job_run
) break;
1267 /* Prepare for the select(2) call: watch for the signal pipe and all of
1270 #define SET_FD(dir, fd) do { \
1272 FD_SET(_fd, &fd_##dir); \
1273 if (_fd >= nfd) nfd = _fd + 1; \
1276 FD_ZERO(&fd_in
); nfd
= 0;
1277 SET_FD(in
, sig_pipe
[0]);
1278 for (job
= job_run
; job
; job
= job
->next
) {
1279 if (job
->out
.fd
>= 0) SET_FD(in
, job
->out
.fd
);
1280 if (job
->err
.fd
>= 0) SET_FD(in
, job
->err
.fd
);
1285 /* Find out what's going on. */
1286 if (select(nfd
, &fd_in
, 0, 0, 0) < 0) {
1287 if (errno
== EINTR
) continue;
1288 else lose("select failed: %s", strerror(errno
));
1291 /* If there were any signals then handle them. */
1292 if (FD_ISSET(sig_pipe
[0], &fd_in
)) {
1295 /* We hit a fatal signal. Kill off the remaining jobs and abort. */
1296 for (job
= job_ready
; job
; job
= next
)
1297 { next
= job
->next
; release_job(job
); }
1298 for (job
= job_run
; job
; job
= next
)
1299 { next
= job
->next
; release_job(job
); }
1304 /* Collect output from running jobs, and clear away any dead jobs once
1305 * we've collected all their output.
1307 for (link
= &job_run
, job
= *link
; job
; job
= next
) {
1308 if (job
->out
.fd
>= 0 && FD_ISSET(job
->out
.fd
, &fd_in
))
1309 prefix_lines(job
, &job
->out
, '|',
1310 job
->st
== JST_VERSION ?
&job
->h
: 0);
1311 if (job
->err
.fd
>= 0 && FD_ISSET(job
->err
.fd
, &fd_in
))
1312 prefix_lines(job
, &job
->err
, '*', 0);
1314 if (job
->kid
> 0 || job
->out
.fd
>= 0 || job
->err
.fd
>= 0)
1317 { *link
= next
; finish_job(job
); }
1322 /*----- Main program ------------------------------------------------------*/
1324 /* Help and related functions. */
1325 static void version(FILE *fp
)
1326 { fprintf(fp
, "%s, runlisp version %s\n", progname
, PACKAGE_VERSION
); }
1328 static void usage(FILE *fp
)
1331 usage: %s [-RUafinqrv] [+RUfinr] [-c CONF] [-o [SECT:]VAR=VAL]\n\
1332 [-O FILE|DIR] [-j NJOBS] [LISP ...]\n",
1336 static void help(FILE *fp
)
1338 version(fp
); fputc('\n', fp
); usage(fp
);
1341 -h, --help Show this help text and exit successfully.\n\
1342 -V, --version Show version number and exit successfully.\n\
1345 -n, --dry-run Don't run run anything (useful with `-v').\n\
1346 -q, --quiet Don't print warning messages.\n\
1347 -v, --verbose Print informational messages (repeatable).\n\
1350 -c, --config-file=CONF Read configuration from CONF (repeatable).\n\
1351 -o, --set-option=[SECT:]VAR=VAL Set configuration variable (repeatable).\n\
1354 -O, --output=FILE|DIR Store image(s) in FILE or DIR.\n\
1355 -R, --remove-other Delete image files for other Lisp systems.\n\
1356 -U, --remove-unknown Delete unrecognized files in image dir.\n\
1357 -a, --all-configured Select all configured implementations.\n\
1358 -f, --force Dump images even if they already exist.\n\
1359 -i, --check-installed Check Lisp systems exist before dumping.\n\
1360 -j, --jobs=NJOBS Run up to NJOBS jobs in parallel.\n\
1361 -r, --remove-image Delete image files, instead of creating.\n",
1365 static void show_job_list(const char *what
, struct job
*job
)
1367 struct dstr d
= DSTR_INIT
;
1371 for (; job
; job
= job
->next
) {
1372 if (first
) first
= 0;
1373 else dstr_puts(&d
, ", ");
1374 dstr_putf(&d
, "`%s'", JOB_NAME(job
));
1376 if (first
) dstr_puts(&d
, "(none)");
1378 moan("%s: %s", what
, d
.p
);
1382 int main(int argc
, char *argv
[])
1384 struct config_section_iter si
;
1385 struct config_section
*sect
;
1386 struct config_var
*var
;
1387 const char *out
= 0, *p
, *q
, *l
;
1390 struct dstr d
= DSTR_INIT
;
1397 /* Command-line options. */
1398 static const struct option opts
[] = {
1399 { "help", 0, 0, 'h' },
1400 { "version", 0, 0, 'V' },
1401 { "output", OPTF_ARGREQ
, 0, 'O' },
1402 { "remove-other", OPTF_NEGATE
, 0, 'R' },
1403 { "remove-unknown", OPTF_NEGATE
, 0, 'U' },
1404 { "all-configured", 0, 0, 'a' },
1405 { "config-file", OPTF_ARGREQ
, 0, 'c' },
1406 { "force", OPTF_NEGATE
, 0, 'f' },
1407 { "check-installed", OPTF_NEGATE
, 0, 'i' },
1408 { "jobs", OPTF_ARGREQ
, 0, 'j' },
1409 { "dry-run", OPTF_NEGATE
, 0, 'n' },
1410 { "set-option", OPTF_ARGREQ
, 0, 'o' },
1411 { "quiet", 0, 0, 'q' },
1412 { "remove-image", OPTF_NEGATE
, 0, 'r' },
1413 { "verbose", 0, 0, 'v' },
1417 /* Initial setup. */
1418 set_progname(argv
[0]);
1422 /* Parse the options. */
1423 optprog
= (/*unconst*/ char *)progname
;
1425 #define FLAGOPT(ch, f) \
1429 case ch | OPTF_NEGATED: \
1434 i
= mdwopt(argc
- 1, argv
+ 1, "hVO:R+U+ac:f+i+j:n+o:qr+v", opts
, 0, 0,
1435 OPTF_NEGATION
| OPTF_NOPROGNAME
);
1438 case 'h': help(stdout
); exit(0);
1439 case 'V': version(stdout
); exit(0);
1440 case 'O': out
= optarg
; break;
1441 FLAGOPT('R', AF_CLEAN
);
1442 FLAGOPT('U', AF_JUNK
);
1443 case 'a': flags
|= AF_ALL
; break;
1444 case 'c': read_config_path(optarg
, 0); flags
|= AF_SETCONF
; break;
1445 FLAGOPT('f', AF_FORCE
);
1446 FLAGOPT('i', AF_CHECKINST
);
1447 case 'j': maxrun
= parse_int("number of jobs", optarg
, 1, 65535); break;
1448 FLAGOPT('n', AF_DRYRUN
);
1449 case 'o': if (set_config_var(optarg
)) flags
|= AF_BOGUS
; break;
1450 case 'q': if (verbose
) verbose
--; break;
1451 FLAGOPT('r', AF_REMOVE
);
1452 case 'v': verbose
++; break;
1453 default: flags
|= AF_BOGUS
; break;
1459 /* CHeck that everything worked. */
1461 if ((flags
&AF_ALL
) ? optind
< argc
: optind
>= argc
) flags
|= AF_BOGUS
;
1462 if (flags
&AF_BOGUS
) { usage(stderr
); exit(127); }
1464 /* Load default configuration if no explicit files were requested. */
1465 if (!(flags
&AF_SETCONF
)) load_default_config();
1467 /* OK, so we've probably got some work to do. Let's set things up ready.
1468 * It'll be annoying if our standard descriptors aren't actually set up
1469 * properly, so we'll make sure those slots are populated. We'll need a
1470 * `/dev/null' descriptor anyway (to be stdin for the jobs). We'll also
1471 * need a temporary directory, and it'll be less temporary if we don't
1472 * arrange to delete it when we're done. And finally we'll need to know
1473 * when a child process exits.
1476 fd
= open("/dev/null", O_RDWR
);
1477 if (fd
< 0) lose("failed to open `/dev/null': %s", strerror(errno
));
1478 if (fd
> 2) { nullfd
= fd
; break; }
1480 configure_fd("null fd", nullfd
, 0, 1);
1483 lose("failed to create signal pipe: %s", strerror(errno
));
1484 configure_fd("signal pipe (read end)", sig_pipe
[0], 1, 1);
1485 configure_fd("signal pipe (write end)", sig_pipe
[1], 1, 1);
1486 sigemptyset(&caught
); sigemptyset(&pending
);
1487 set_signal_handler("SIGTERM", SIGTERM
, SIGF_IGNOK
);
1488 set_signal_handler("SIGINT", SIGINT
, SIGF_IGNOK
);
1489 set_signal_handler("SIGHUP", SIGHUP
, SIGF_IGNOK
);
1490 set_signal_handler("SIGCHLD", SIGCHLD
, 0);
1492 /* Create the temporary directory and export it into the configuration. */
1494 config_set_var(&config
, builtin
, CF_LITERAL
, "@%tmp-dir", tmpdir
);
1495 config_set_var(&config
, builtin
, 0,
1496 "@tmp-dir", "${@BUILTIN:@%tmp-dir}/${@name}");
1498 /* Work out where the image files are going to go. If there's no `-O'
1499 * option then we use the main `image-dir'. Otherwise what happens depends
1500 * on whether this is a file or a directory.
1503 config_set_var(&config
, builtin
, 0,
1504 "@image-link", "${@image-dir}/${image-file}");
1505 var
= config_find_var(&config
, builtin
, CF_INHERIT
, "@image-dir");
1506 assert(var
); out
= config_subst_var_alloc(&config
, builtin
, var
);
1507 } else if (!stat(out
, &st
) && S_ISDIR(st
.st_mode
)) {
1508 config_set_var(&config
, builtin
, CF_LITERAL
, "@%out-dir", out
);
1509 config_set_var(&config
, builtin
, 0,
1510 "@image-link", "${@BUILTIN:@%out-dir}/${image-file}");
1511 } else if (argc
- optind
!= 1)
1512 lose("can't dump multiple Lisps to a single output file");
1513 else if (flags
&AF_JUNK
)
1514 lose("can't clear junk in a single output file");
1515 else if (flags
&AF_CLEAN
)
1516 lose("can't clean other images with a single output file");
1518 config_set_var(&config
, builtin
, CF_LITERAL
, "@image-link", out
);
1520 /* Set the staging and versioned filenames. */
1521 config_set_var(&config
, builtin
, 0,
1522 "@image-out", "${@image-link}-${@hash}");
1523 config_set_var(&config
, builtin
, 0, "@image-new", "${@image-out}.new");
1524 config_set_var(&config
, builtin
, 0,
1525 "@image-newlink", "${@image-link}.new");
1527 config_set_var(&config
, builtin
, 0, "@script",
1528 "${@ENV:RUNLISP_EVAL?"
1529 "${@CONFIG:eval-script?"
1530 "${@data-dir}/eval.lisp}}");
1532 /* Configure an initial value for `@hash'. This is necessary so that
1533 * `add_job' can expand `dump-image' to check that the command exists.
1535 config_set_var(&config
, builtin
, CF_LITERAL
, "@hash", "!!!unset!!!");
1537 /* Dump the final configuration if we're being very verbose. */
1538 if (verbose
>= 5) dump_config();
1540 /* There are a number of different strategies we might employ, depending on
1541 * the exact request.
1544 * REMOVE CLEAN JUNK selected others junk?
1546 * * nil nil ready/delete -- no
1547 * * nil t ready/delete none yes
1548 * nil t nil ready delete no
1549 * nil t t ready -- yes
1550 * t t nil -- delete no
1554 /* First step: if `AF_REMOVE' and `AF_CLEAN' are not both set, then scan
1555 * the selected Lisp systems and add them to the appropriate queue.
1557 * Bit-hack: if they are not both set, then their complements are not both
1560 if (~flags
&(AF_REMOVE
| AF_CLEAN
)) {
1562 /* Determine the flags for `add_job' when we select the Lisp systems. If
1563 * we intend to clear junk then we must notice the image names we
1564 * encounter. If we're supposed to check that Lisps exist before dumping
1565 * then do that -- but it doesn't make any sense for deletion.
1567 f
= flags
&AF_REMOVE ? JQ_DELETE
: JQ_READY
;
1568 if (flags
&AF_JUNK
) f
|= JF_NOTICE
;
1569 if (flags
&AF_CHECKINST
) f
|= JF_CHECKINST
;
1570 if (!(flags
&(AF_FORCE
| AF_REMOVE
))) f
|= JF_CHECKEXIST
;
1572 /* If we have named Lisps, then process them. */
1573 if (!(flags
&AF_ALL
))
1574 for (i
= optind
; i
< argc
; i
++)
1575 add_named_job(f
, argv
[i
], strlen(argv
[i
]));
1577 /* Otherwise we're supposed to dump `all' of them. If there's a `dump'
1578 * configuration setting then we need to parse that. Otherwise we just
1582 var
= config_find_var(&config
, toplevel
, CF_INHERIT
, "dump");
1584 /* No setting. Just do all of the Lisps which look available. */
1587 for (config_start_section_iter(&config
, &si
);
1588 (sect
= config_next_section(&si
)); )
1591 /* Parse the `dump' list. */
1593 dstr_reset(&d
); config_subst_var(&config
, toplevel
, var
, &d
);
1594 p
= d
.p
; l
= p
+ d
.len
;
1596 while (p
< l
&& ISSPACE(*p
)) p
++;
1599 while (p
< l
&& !ISSPACE(*p
) && *p
!= ',') p
++;
1600 add_named_job(f
, q
, p
- q
);
1601 while (p
< l
&& ISSPACE(*p
)) p
++;
1602 if (p
< l
&& *p
== ',') p
++;
1608 /* Second step: if exactly one of `AF_CLEAN' and `AF_JUNK' is set, then we
1609 * need to scan all of the remaining Lisps and add them to the `delete'
1612 if (!(flags
&AF_CLEAN
) != !(flags
&AF_JUNK
)) {
1614 /* Determine the flag settings. If we're junking, then we're not
1615 * cleaning -- we just want to mark images belonging to other Lisps as
1616 * off-limits to the junking scan.
1618 f
= flags
&AF_CLEAN ? JQ_DELETE
: JQ_NONE
| JF_NOTICE
;
1620 /* Now scan the Lisp systems. */
1621 for (config_start_section_iter(&config
, &si
);
1622 (sect
= config_next_section(&si
)); )
1626 /* Terminate the job queues. */
1627 *job_ready_tail
= 0;
1628 *job_delete_tail
= 0;
1630 /* Report on what it is we're about to do. */
1632 show_job_list("dumping Lisp images", job_ready
);
1633 show_job_list("deleting Lisp images", job_delete
);
1636 /* If there turns out to be nothing to do, then mention this. */
1637 if (!(flags
&AF_REMOVE
) && verbose
>= 2 && !job_ready
)
1638 moan("no Lisp images to dump");
1640 /* Run the dumping jobs. */
1643 /* Check for any last signals. If we hit any fatal signals then we should
1644 * kill ourselves so that the exit status will be right.
1647 if (sigloss
) { cleanup(); signal(sigloss
, SIG_DFL
); raise(sigloss
); }
1649 /* Now delete Lisps which need deleting. */
1650 while (job_delete
) {
1651 job
= job_delete
; job_delete
= job
->next
;
1652 if (flags
&AF_DRYRUN
) {
1654 moan("not deleting `%s' image link `%s' (dry run)",
1655 JOB_NAME(job
), job
->imglink
);
1656 if (job
->oldimg
&& verbose
>= 2)
1657 moan("not deleting `%s' image `%s' (dry run)",
1658 JOB_NAME(job
), job
->oldimg
);
1661 moan("deleting `%s' image `%s'",
1662 JOB_NAME(job
), job
->imglink
);
1663 if (unlink(job
->imglink
) && errno
!= ENOENT
)
1664 bad("failed to delete `%s' image link `%s': %s",
1665 JOB_NAME(job
), job
->imglink
, strerror(errno
));
1666 if (job
->oldimg
&& unlink(job
->oldimg
) && errno
!= ENOENT
)
1667 bad("failed to delete `%s' image `%s': %s",
1668 JOB_NAME(job
), job
->oldimg
, strerror(errno
));
1672 /* Finally, maybe delete all of the junk files in the image directory. */
1673 if (flags
&AF_JUNK
) {
1676 lose("failed to open image directory `%s': %s", out
, strerror(errno
));
1678 dstr_puts(&d
, out
); dstr_putc(&d
, '/'); o
= d
.len
;
1680 moan("cleaning up junk in image directory `%s'", out
);
1682 de
= readdir(dir
); if (!de
) break;
1683 if (de
->d_name
[0] == '.' &&
1684 (!de
->d_name
[1] || (de
->d_name
[1] == '.' && !de
->d_name
[2])))
1686 n
= strlen(de
->d_name
);
1687 d
.len
= o
; dstr_putm(&d
, de
->d_name
, n
+ 1);
1688 if (!treap_lookup(&good
, de
->d_name
, n
)) {
1689 if (flags
&AF_DRYRUN
) {
1691 moan("not deleting junk file `%s' (dry run)", d
.p
);
1694 moan("deleting junk file `%s'", d
.p
);
1695 if (unlink(d
.p
) && errno
!= ENOENT
)
1696 bad("failed to delete junk file `%s': %s", d
.p
, strerror(errno
));
1706 /*----- That's all, folks -------------------------------------------------*/