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
);
550 if (verbose
>= 3) moan("noticed non-junk file `%.*s'", (int)sz
, p
);
554 /* There are basically two kinds of jobs.
556 * An `internal' job -- state `JST_INTERN' -- can be handled entirely within
557 * this process. Internal jobs have trivial lifecycles: they're created, put
558 * on a queue, executed, and thrown away. Jobs are executed when some code
559 * decides to walk the appropriate queue and do the work. As a result, they
560 * don't need to have distinctive states: `JST_INTERN' only exists to
561 * distinguish internal jobs from active ones if they somehow manage to end
562 * up in the external-job machinery.
564 * External jobs all work in basically the same way: we fork and exec a
565 * sequence of subprocess to do the work. The majority of handling external
566 * jobs is in the care and feeding of these subprocesses, so they end up on
567 * various lists primarily concerned with the state of the subprocesses, and
568 * the progress of the job through its sequence of subprocesses is recorded
569 * in the job's `st' field.
571 * External jobs have a comparatively complicated lifecycle.
573 * * Initially, the job is on the `ready' queue by `add_job'. It has no
574 * child process or log file.
576 * * At some point, `start_jobs' decides to start this job up: a log file
577 * is created (if the job doesn't have one already), a child process is
578 * forked, and pipes are set up to capture the child's output. It gets
579 * moved to the `run' list (which is not maintained in any particular
580 * order). Jobs on the `run' list participate in the main select(2)
583 * * When the job's child process dies and the pipes capturing its output
584 * streams finally dry up, the job is considered finished. What happens
585 * next depends on its state: either it gets updated somehow, and pushed
586 * back onto the end of the `ready' queue so that another child can be
587 * started, or the job is finished and dies.
589 * The counter `nrun' counts the number of actually running jobs, i.e., those
590 * with living child processes. This doesn't simply count the number of jobs
591 * on the `run' list: remember that the latter also contains jobs whose child
592 * has died, but whose output has not yet been collected.
595 /* Consider a Lisp system description and maybe add a job to the right queue.
597 * The Lisp system is described by the configuration section SECT. Most of
598 * the function is spent on inspecting this section for suitability and
599 * deciding what to do about it.
601 * The precise behaviour depends on F, which should be the bitwise-OR of a
602 * `JQ_...' constant and zero or more flags, as follows.
604 * * The bits covered by `JMASK_QUEUE' identify which queue the job should
605 * be added to if the section defines a cromulent Lisp system:
607 * -- `JQ_NONE' -- don't actually make a job at all;
608 * -- `JQ_READY' -- add the Lisp to the `job_ready' queue, so we'll; or
609 * -- `JQ_DELETE' -- add the Lisp to the `job_delete' queue.
611 * * `JF_PICKY': The user identified this Lisp system explicitly, so
612 * complain if the configuration section doesn't look right. This is
613 * clear if the caller is just enumerating all of the configuration
614 * sections: without this feature, we'd be checking everything twice,
615 * which (a) is inefficient, and -- more importantly -- (b) could lead to
616 * problems if the two checks are inconsistent.
618 * * `JF_CHECKINST': Ignore this Lisp if `AF_CHECKINST' is set and it's not
619 * actually installed. (This is usually set for `JQ_READY' calls, so
620 * that we don't try to dump Lisps which aren't there, but clear for
621 * `JQ_DELETE' calls so that we clear out Lisps which have gone away.)
623 * * `JF_CHECKEXIST': Ignore this Lisp if its image file already exists.
625 * * `JF_NOTICE': Record the Lisp's image basename in the `good' treap so
626 * that we can identify everything else we find in the image directory as
629 #define JMASK_QUEUE 3u /* which queue to add good Lisp to */
630 #define JQ_NONE 0u /* don't add to any queue */
631 #define JQ_READY 1u /* `job_ready' */
632 #define JQ_DELETE 2u /* `job_delete' */
633 #define JF_PICKY 4u /* lose if section isn't Lisp defn */
634 #define JF_CHECKINST 8u /* maybe check Lisp is installed */
635 #define JF_CHECKEXIST 16u /* skip if image already exists */
636 #define JF_NOTICE 32u /* record Lisp's image basename */
638 #define JADD_NAMED (JQ_READY | JF_PICKY | JF_CHECKINST)
639 #define JADD_DEFAULT (JQ_READY | JF_CHECKINST)
640 #define JADD_CLEANUP (JQ_DELETE)
641 #define JADD_NOTICE (JQ_NONE)
642 static void add_job(unsigned f
, struct config_section
*sect
)
645 struct job
*job
, ***tail
;
646 struct treap_path jobpath
;
647 struct config_var
*dumpvar
, *runvar
, *imgvar
;
648 struct dstr d
= DSTR_INIT
, dd
= DSTR_INIT
;
649 struct argv av_version
= ARGV_INIT
, av_dump
= ARGV_INIT
;
651 char *imgnewlink
= 0, *imglink
= 0, *oldimg
= 0, *p
;
657 /* We'll want the section's name for all sorts of things. */
658 name
= CONFIG_SECTION_NAME(sect
);
659 len
= CONFIG_SECTION_NAMELEN(sect
);
661 /* Check to see whether this Lisp system is already queued up.
663 * We'll get around to adding the new job node to the treap right at the
664 * end, so use a separate path object to keep track of where to put it.
666 job
= treap_probe(&jobs
, name
, len
, &jobpath
);
668 if ((f
&JF_PICKY
) && verbose
>= 1)
669 moan("ignoring duplicate Lisp `%s'", JOB_NAME(job
));
673 /* Check that the section defines a Lisp, and that it can be dumped.
675 * It's not obvious that this is right. Maybe there should be some
676 * additional flag so that we don't check dumpability if we're planning to
677 * delete the image. But it /is/ right: since the thing which tells us
678 * whether we can dump is that the section tells us the image's name, if
679 * it can't be dumped then we won't know what file to delete! So we have
682 runvar
= config_find_var(&config
, sect
, CF_INHERIT
, "run-script");
684 if (f
&JF_PICKY
) lose("unknown Lisp implementation `%s'", name
);
685 else if (verbose
>= 3) moan("skipping non-Lisp section `%s'", name
);
688 imgvar
= config_find_var(&config
, sect
, CF_INHERIT
, "image-file");
691 lose("Lisp implementation `%s' doesn't use custom images", name
);
692 else if (verbose
>= 3)
693 moan("skipping Lisp `%s': no custom image support", name
);
697 /* Check that the other necessary variables are present. */
698 dumpvar
= config_find_var(&config
, sect
, CF_INHERIT
, "dump-image");
700 lose("variable `dump-image' not defined for Lisp `%s'", name
);
702 /* Build the job's command lines. */
703 config_subst_split_var(&config
, sect
, runvar
, &av_version
);
705 lose("empty `run-script' command for Lisp implementation `%s'", name
);
706 argv_append(&av_version
,
707 config_subst_string_alloc
708 (&config
, sect
, "<internal>",
709 "?${lisp-version?(lisp-implementation-version)}"));
710 config_subst_split_var(&config
, sect
, dumpvar
, &av_dump
);
712 lose("empty `dump-image' command for Lisp implementation `%s'", name
);
714 /* If we're supposed to check that the Lisp exists before proceeding then
715 * do that. There are /two/ commands to check: the basic Lisp command,
716 * /and/ the command to actually do the dumping, which might not be the
717 * same thing. (Be careful not to check the same command twice, though,
718 * because that would cause us to spam the user with redundant
721 if ((f
&JF_CHECKINST
) && (flags
&AF_CHECKINST
)) {
722 fef
= (verbose
>= 3 ? FEF_VERBOSE
: 0);
723 if (!found_in_path_p(av_version
.v
[0], fef
)) {
725 moan("skipping Lisp `%s': can't find Lisp command `%s'",
726 name
, av_version
.v
[0]);
729 if (STRCMP(av_version
.v
[0], !=, av_dump
.v
[0]) &&
730 !found_in_path_p(av_dump
.v
[0], fef
)) {
732 moan("skipping Lisp `%s': can't find dump command `%s'",
738 /* Collect the output image file names. */
740 config_subst_string_alloc(&config
, sect
, "<internal>", "${@image-link}");
742 config_subst_string_alloc(&config
, sect
,
743 "<internal>", "${@image-newlink}");
745 /* Determine the image link basename. If necessary, record it so that it
746 * doesn't get junked.
748 dstr_reset(&dd
); config_subst_var(&config
, sect
, imgvar
, &dd
);
749 if (f
&JF_NOTICE
) notice_filename(dd
.p
, dd
.len
);
751 /* Fill in the directory name for the output image. */
753 p
= strrchr(imglink
, '/');
754 if (p
) dstr_putm(&d
, imglink
, p
+ 1 - imglink
);
756 /* Inspect the existing image link if there is one, and record its
761 /* Read the link destination. The `lstat'/`readlink' two-step is
762 * suggested by the POSIX specification.
764 if (lstat(imglink
, &st
)) {
765 if (verbose
>= (errno
== ENOENT ?
3 : 1))
766 moan("failed to read metadata for Lisp `%s' image link `%s': %s",
767 name
, imglink
, strerror(errno
));
770 if (!S_ISLNK(st
.st_mode
)) {
772 moan("Lisp `%s' image link `%s' isn't a symbolic link",
776 dstr_ensure(&d
, st
.st_size
+ 1);
777 n
= readlink(imglink
, d
.p
+ d
.len
, d
.sz
- d
.len
);
779 moan("failed to read Lisp `%s' image link `%s': %s",
780 name
, imglink
, strerror(errno
));
783 if (n
== d
.sz
- d
.len
) continue;
785 /* Check that the link has the right form. (We don't want to delete the
786 * referent if it's not actually our image.)
788 * We expect the referent to look like ${image-file} followed by a hyphen
789 * and some hex digits.
792 STRNCMP(d
.p
+ d
.len
, !=, dd
.p
, dd
.len
) ||
793 d
.p
[d
.len
+ dd
.len
] != '-' ||
794 !hex_digits_p(d
.p
+ (d
.len
+ dd
.len
+ 1), n
- (dd
.len
+ 1))) {
796 moan("Lisp `%s' image link `%s' has unexpected referent `%s'",
801 /* OK, so it looks legit. Protect it from being junked. */
802 if (f
&JF_NOTICE
) notice_filename(d
.p
+ d
.len
, n
);
803 d
.p
[d
.len
+ n
] = 0; d
.len
+= n
;
804 oldimg
= xstrndup(d
.p
, d
.len
);
808 /* All preflight checks complete. Build the job and hook it onto the end
809 * of the list. (Steal the command-line vector so that we don't try to
810 * free it during cleanup.)
812 switch (f
&JMASK_QUEUE
) {
813 case JQ_NONE
: jst
= JST_INTERN
; tail
= 0; break;
814 case JQ_READY
: jst
= JST_VERSION
; tail
= &job_ready_tail
; break;
815 case JQ_DELETE
: jst
= JST_INTERN
; tail
= &job_delete_tail
; break;
818 job
= xmalloc(sizeof(*job
));
819 job
->st
= jst
; job
->sect
= sect
; job
->dumpvar
= dumpvar
;
820 job
->kid
= -1; job
->log
= 0;
821 job
->out
.fd
= -1; job
->out
.buf
= 0;
822 job
->err
.fd
= -1; job
->err
.buf
= 0;
823 job
->av_version
= av_version
; argv_init(&av_version
);
824 argv_init(&job
->av_dump
);
825 job
->imgnew
= 0; job
->imghash
= 0;
826 job
->imgnewlink
= imgnewlink
; imgnewlink
= 0;
827 job
->imglink
= imglink
; imglink
= 0;
828 job
->oldimg
= oldimg
; oldimg
= 0;
829 treap_insert(&jobs
, &jobpath
, &job
->_node
, name
, len
);
830 if (tail
) { **tail
= job
; *tail
= &job
->next
; }
833 /* All done. Cleanup time. */
834 for (i
= 0; i
< av_version
.n
; i
++) free(av_version
.v
[i
]);
835 for (i
= 0; i
< av_dump
.n
; i
++) free(av_dump
.v
[i
]);
836 free(imgnewlink
); free(imglink
); free(oldimg
);
837 dstr_release(&d
); dstr_release(&dd
);
838 argv_release(&av_version
); argv_release(&av_dump
);
841 /* As `add_job' above, but look the Lisp implementation up by name.
843 * The flags passed to `add_job' are augmented with `JF_PICKY' because this
844 * is an explicitly-named Lisp implementation.
846 static void add_named_job(unsigned f
, const char *name
, size_t len
)
848 struct config_section
*sect
;
850 sect
= config_find_section_n(&config
, 0, name
, len
);
851 if (!sect
) lose("unknown Lisp implementation `%.*s'", (int)len
, name
);
852 add_job(f
| JF_PICKY
, sect
);
855 /* Free the JOB and all the resources it holds.
857 * Close the pipes; kill the child process. Everything must go.
859 static void release_job(struct job
*job
)
864 if (job
->kid
> 0) kill(job
->kid
, SIGKILL
); /* ?? */
865 if (job
->log
&& job
->log
!= stdout
) fclose(job
->log
);
866 free(job
->imgnew
); free(job
->imghash
);
867 free(job
->imglink
); free(job
->imgnewlink
);
869 for (i
= 0; i
< job
->av_version
.n
; i
++) free(job
->av_version
.v
[i
]);
870 for (i
= 0; i
< job
->av_dump
.n
; i
++) free(job
->av_dump
.v
[i
]);
871 argv_release(&job
->av_version
); argv_release(&job
->av_dump
);
872 free(job
->out
.buf
); if (job
->out
.fd
>= 0) close(job
->out
.fd
);
873 free(job
->err
.buf
); if (job
->err
.fd
>= 0) close(job
->err
.fd
);
874 j
= treap_remove(&jobs
, JOB_NAME(job
), JOB_NAMELEN(job
)); assert(j
== job
);
878 /* Do all the necessary things when JOB finishes (successfully or not).
880 * Eventually the job is either freed (using `release_job'), or updated and
881 * stuffed back into the `job_run' queue. The caller is expected to have
882 * already unlinked the job from its current list.
884 static void finish_job(struct job
*job
)
888 struct dstr d
= DSTR_INIT
;
892 /* Start a final line to the job log describing its eventual fate.
894 * This is where we actually pick apart the exit status. Set `ok' if it
895 * actually succeeded, because that's all anything else cares about.
897 fprintf(job
->log
, "%-13s > ", JOB_NAME(job
));
898 if (WIFEXITED(job
->exit
)) {
899 if (!WEXITSTATUS(job
->exit
))
900 { fputs("completed successfully\n", job
->log
); ok
= 1; }
902 fprintf(job
->log
, "failed with exit status %d\n",
903 WEXITSTATUS(job
->exit
));
904 } else if (WIFSIGNALED(job
->exit
))
905 fprintf(job
->log
, "killed by signal %d (%s%s)", WTERMSIG(job
->exit
),
906 #if defined(HAVE_STRSIGNAL)
907 strsignal(WTERMSIG(job
->exit
)),
908 #elif defined(HAVE_DECL_SYS_SIGLIST)
909 sys_siglist
[WTERMSIG(job
->exit
)],
914 WCOREDUMP(job
->exit
) ?
"; core dumped" :
918 fprintf(job
->log
, "exited with incomprehensible status %06o\n",
921 /* What happens next depends on the state of the job. This is the main
922 * place which advances the job state machine.
924 if (ok
) switch (job
->st
) {
927 /* We've retrieved the Lisp system's version string. */
929 /* Complete the hashing and convert to hex. */
930 hbuf
= (unsigned char *)buf
+ 32; sha256_done(&job
->h
, hbuf
);
931 for (i
= 0; i
< 8; i
++) sprintf(buf
+ 2*i
, "%02x", hbuf
[i
]);
933 moan("Lisp `%s' version hash = %s", JOB_NAME(job
), buf
);
935 /* Determine the final version-qualified name for the image. */
936 config_set_var(&config
, job
->sect
, CF_LITERAL
, "@hash", buf
);
938 config_subst_string_alloc(&config
, job
->sect
,
939 "<internal>", "${@image-out}");
941 config_subst_string_alloc(&config
, job
->sect
,
942 "<internal>", "${@image-new}");
944 /* Determine the basename of the final image. */
945 p
= strrchr(job
->imghash
, '/'); if (p
) p
++; else p
= job
->imghash
;
947 /* Inspect the current link pointer to see if we have the right
950 if (!(flags
&AF_FORCE
) &&
952 STRCMP(job
->oldimg
, ==, job
->imghash
) &&
953 !access(job
->oldimg
, F_OK
)) {
955 moan("Lisp `%s' image `%s' already up-to-date",
956 JOB_NAME(job
), job
->imghash
);
960 /* Make sure that there's a clear space for the new image to be
963 if (!(flags
&AF_DRYRUN
) && unlink(job
->imgnew
) && errno
!= ENOENT
) {
964 bad("failed to clear Lisp `%s' image staging path `%s': %s",
965 JOB_NAME(job
), job
->imgnew
, strerror(errno
));
969 /* If we're still here then we've decided to dump a new image. Update
970 * the job state, and put it back on the run queue.
972 config_subst_split_var(&config
, job
->sect
,
973 job
->dumpvar
, &job
->av_dump
);
974 assert(job
->av_dump
.n
);
976 *job_ready_tail
= job
; job_ready_tail
= &job
->next
; job
->next
= 0;
981 /* We've finished dumping a custom image. It's time to apply the
985 /* Rename the image into place. If this fails, blame it on the dump
986 * job, because the chances are good that it failed to produce the
990 moan("rename completed Lisp `%s' image `%s' to `%s'",
991 JOB_NAME(job
), job
->imgnew
, job
->imghash
);
992 if (rename(job
->imgnew
, job
->imghash
)) {
993 fprintf(job
->log
, "%-13s > failed to rename Lisp `%s' "
994 "output image `%s' to `%s': %s",
995 JOB_NAME(job
), JOB_NAME(job
),
996 job
->imgnew
, job
->imghash
, strerror(errno
));
1000 /* Notice the image so that it doesn't get junked. */
1001 if (flags
&AF_JUNK
) {
1002 p
= strrchr(job
->imghash
, '/'); if (p
) p
++; else p
= job
->imghash
;
1003 notice_filename(p
, strlen(p
));
1006 /* Determine the basename of the final image. */
1007 p
= strrchr(job
->imghash
, '/'); if (p
) p
++; else p
= job
->imghash
;
1009 /* Build the symlink. Start by setting the link in the staging path,
1010 * and then rename, in order to ensure continuity.
1012 if (unlink(job
->imgnewlink
) && errno
!= ENOENT
) {
1013 bad("failed to clear Lisp `%s' link staging path `%s': %s",
1014 JOB_NAME(job
), job
->imgnewlink
, strerror(errno
));
1018 moan("establish Lisp `%s' image link `%s' referring to `%s'",
1019 JOB_NAME(job
), job
->imglink
, job
->imghash
);
1020 if (symlink(p
, job
->imgnewlink
)) {
1021 bad("failed to create Lisp `%s' image link `%s': %s",
1022 JOB_NAME(job
), job
->imgnewlink
, strerror(errno
));
1025 if (rename(job
->imgnewlink
, job
->imglink
)) {
1026 bad("failed to rename Lisp `%s' image link `%s' to `%s': %s",
1027 JOB_NAME(job
), job
->imgnewlink
, job
->imglink
, strerror(errno
));
1030 if (job
->oldimg
&& STRCMP(job
->oldimg
, !=, job
->imghash
)) {
1032 moan("remove old Lisp `%s' image `%s'",
1033 JOB_NAME(job
), job
->oldimg
);
1034 if (unlink(job
->oldimg
) && errno
!= ENOENT
) {
1036 moan("failed to delete old Lisp `%s' image `%s': %s",
1037 JOB_NAME(job
), job
->oldimg
, strerror(errno
));
1041 /* I think we're all done. */
1048 /* If the job failed and we're being quiet then write out the log that we
1051 if (!ok
&& verbose
< 2) {
1054 n
= fread(buf
, 1, sizeof(buf
), job
->log
);
1055 if (n
) fwrite(buf
, 1, n
, stdout
);
1056 if (n
< sizeof(buf
)) break;
1060 /* Also make a node to stderr about what happened. (Just to make sure
1061 * that we've gotten someone's attention.)
1063 if (!ok
) bad("failed to dump Lisp `%s'", JOB_NAME(job
));
1065 /* Finally free the job control block. */
1066 if (job
) release_job(job
);
1070 /* Called after `SIGCHLD': collect exit statuses and mark jobs as dead. */
1071 static void reap_children(void)
1079 /* Collect a child exit status. If there aren't any more then we're
1082 kid
= waitpid(0, &st
, WNOHANG
);
1083 if (kid
<= 0) break;
1085 /* Try to find a matching job. If we can't, then we should just ignore
1088 for (job
= job_run
; job
; job
= job
->next
)
1089 if (job
->kid
== kid
) goto found
;
1093 /* Mark the job as dead, and save its exit status. */
1094 job
->exit
= st
; job
->kid
= -1; nrun
--;
1097 /* If there was a problem with waitpid(2) then report it. */
1098 if (kid
< 0 && errno
!= ECHILD
)
1099 lose("failed to collect child process exit status: %s", strerror(errno
));
1102 /* Execute the handler for some JOB. */
1103 static NORETURN
void job_child(struct job
*job
, struct argv
*av
)
1106 moan("failed to run `%s': %s", av
->v
[0], strerror(errno
));
1110 /* Start up jobs while there are (a) jobs to run and (b) slots to run them
1113 static void start_jobs(void)
1115 struct dstr d
= DSTR_INIT
;
1116 int p_out
[2], p_err
[2];
1121 /* Keep going until either we run out of jobs, or we've got enough running
1124 while (job_ready
&& nrun
< maxrun
) {
1126 /* Set things up ready. If things go wrong, we need to know what stuff
1127 * needs to be cleaned up.
1129 job
= job_ready
; job_ready
= job
->next
;
1130 if (!job_ready
) job_ready_tail
= &job_ready
;
1131 p_out
[0] = p_out
[1] = p_err
[0] = p_err
[1] = -1;
1133 /* Figure out what to do. */
1135 case JST_VERSION
: av
= &job
->av_version
; break;
1136 case JST_DUMP
: av
= &job
->av_dump
; break;
1140 /* If we're not actually going to do anything, now is the time to not do
1141 * that. We should do the version-hashing step unconditionally.
1147 if (flags
&AF_DRYRUN
) {
1150 (verbose
>= 2 && !(flags
&AF_CHECKINST
)
1151 ? TEF_VERBOSE
: 0)))
1153 else if (verbose
>= 2)
1154 printf("%-13s > not dumping `%s' (dry run)\n",
1155 JOB_NAME(job
), JOB_NAME(job
));
1164 /* Do one-time setup for external jobs. */
1167 /* Make a temporary subdirectory for this job to use. */
1168 dstr_reset(&d
); dstr_putf(&d
, "%s/%s", tmpdir
, JOB_NAME(job
));
1169 if (mkdir(d
.p
, 0700)) {
1170 bad("failed to create working directory for job `%s': %s",
1171 JOB_NAME(job
), strerror(errno
));
1175 /* Create the job's log file. If we're being verbose then that's just
1176 * our normal standard output -- /not/ stderr: it's likely that users
1177 * will want to pipe this stuff through a pager or something, and
1178 * that'll be easier if we use stdout. Otherwise, make a file in the
1179 * temporary directory.
1184 dstr_puts(&d
, "/log"); job
->log
= fopen(d
.p
, "w+");
1186 lose("failed to open log file `%s': %s", d
.p
, strerror(errno
));
1190 /* Make the pipes to capture the child process's standard output and
1193 if (pipe(p_out
) || pipe(p_err
)) {
1194 bad("failed to create pipes for job `%s': %s",
1195 JOB_NAME(job
), strerror(errno
));
1198 if (configure_fd("job stdout pipe", p_out
[0], 1, 1) ||
1199 configure_fd("job stdout pipe", p_out
[1], 0, 1) ||
1200 configure_fd("job stderr pipe", p_err
[0], 1, 1) ||
1201 configure_fd("job stderr pipe", p_err
[1], 0, 1) ||
1202 configure_fd("log file", fileno(job
->log
), 1, 1))
1205 /* Initialize the output-processing structures ready for use. */
1206 if (job
->st
== JST_VERSION
) sha256_init(&job
->h
);
1207 job
->out
.buf
= xmalloc(MAXLINE
); job
->out
.off
= job
->out
.len
= 0;
1208 job
->out
.fd
= p_out
[0]; p_out
[0] = -1;
1209 job
->err
.buf
= xmalloc(MAXLINE
); job
->err
.off
= job
->err
.len
= 0;
1210 job
->err
.fd
= p_err
[0]; p_err
[0] = -1;
1212 /* Print a note to the top of the log. */
1213 dstr_reset(&d
); argv_string(&d
, av
);
1214 fprintf(job
->log
, "%-13s > starting %s\n", JOB_NAME(job
), d
.p
);
1216 /* Flush the standard output stream. (Otherwise the child might try to
1221 /* Spin up the child process. */
1224 bad("failed to fork process for job `%s': %s",
1225 JOB_NAME(job
), strerror(errno
));
1229 if (dup2(nullfd
, 0) < 0 ||
1230 dup2(p_out
[1], 1) < 0 ||
1231 dup2(p_err
[1], 2) < 0)
1232 lose("failed to juggle job `%s' file descriptors: %s",
1233 JOB_NAME(job
), strerror(errno
));
1237 /* Close the ends of the pipes that we don't need. Move the job into
1240 close(p_out
[1]); close(p_err
[1]);
1241 job
->kid
= kid
; job
->next
= job_run
; job_run
= job
; nrun
++;
1245 /* Clean up the wreckage if it didn't work. */
1246 if (p_out
[0] >= 0) close(p_out
[0]);
1247 if (p_out
[1] >= 0) close(p_out
[1]);
1248 if (p_err
[0] >= 0) close(p_err
[0]);
1249 if (p_err
[1] >= 0) close(p_err
[1]);
1253 /* All done except for some final tidying up. */
1257 /* Take care of all of the jobs until they're all done. */
1258 static void run_jobs(void)
1260 struct job
*job
, *next
, **link
;
1266 /* If there are jobs still to be started and we have slots to spare then
1267 * start some more up.
1271 /* If the queues are now all empty then we're done. (No need to check
1272 * `job_ready' here: `start_jobs' would have started them if `job_run'
1275 if (!job_run
) break;
1277 /* Prepare for the select(2) call: watch for the signal pipe and all of
1280 #define SET_FD(dir, fd) do { \
1282 FD_SET(_fd, &fd_##dir); \
1283 if (_fd >= nfd) nfd = _fd + 1; \
1286 FD_ZERO(&fd_in
); nfd
= 0;
1287 SET_FD(in
, sig_pipe
[0]);
1288 for (job
= job_run
; job
; job
= job
->next
) {
1289 if (job
->out
.fd
>= 0) SET_FD(in
, job
->out
.fd
);
1290 if (job
->err
.fd
>= 0) SET_FD(in
, job
->err
.fd
);
1295 /* Find out what's going on. */
1296 if (select(nfd
, &fd_in
, 0, 0, 0) < 0) {
1297 if (errno
== EINTR
) continue;
1298 else lose("select failed: %s", strerror(errno
));
1301 /* If there were any signals then handle them. */
1302 if (FD_ISSET(sig_pipe
[0], &fd_in
)) {
1305 /* We hit a fatal signal. Kill off the remaining jobs and abort. */
1306 for (job
= job_ready
; job
; job
= next
)
1307 { next
= job
->next
; release_job(job
); }
1308 for (job
= job_run
; job
; job
= next
)
1309 { next
= job
->next
; release_job(job
); }
1314 /* Collect output from running jobs, and clear away any dead jobs once
1315 * we've collected all their output.
1317 for (link
= &job_run
, job
= *link
; job
; job
= next
) {
1318 if (job
->out
.fd
>= 0 && FD_ISSET(job
->out
.fd
, &fd_in
))
1319 prefix_lines(job
, &job
->out
, '|',
1320 job
->st
== JST_VERSION ?
&job
->h
: 0);
1321 if (job
->err
.fd
>= 0 && FD_ISSET(job
->err
.fd
, &fd_in
))
1322 prefix_lines(job
, &job
->err
, '*', 0);
1324 if (job
->kid
> 0 || job
->out
.fd
>= 0 || job
->err
.fd
>= 0)
1327 { *link
= next
; finish_job(job
); }
1332 /*----- Main program ------------------------------------------------------*/
1334 /* Help and related functions. */
1335 static void version(FILE *fp
)
1336 { fprintf(fp
, "%s, runlisp version %s\n", progname
, PACKAGE_VERSION
); }
1338 static void usage(FILE *fp
)
1341 usage: %s [-RUafinqrv] [+RUfinr] [-c CONF] [-o [SECT:]VAR=VAL]\n\
1342 [-O FILE|DIR] [-j NJOBS] [LISP ...]\n",
1346 static void help(FILE *fp
)
1348 version(fp
); fputc('\n', fp
); usage(fp
);
1351 -h, --help Show this help text and exit successfully.\n\
1352 -V, --version Show version number and exit successfully.\n\
1355 -n, --dry-run Don't run run anything (useful with `-v').\n\
1356 -q, --quiet Don't print warning messages.\n\
1357 -v, --verbose Print informational messages (repeatable).\n\
1360 -c, --config-file=CONF Read configuration from CONF (repeatable).\n\
1361 -o, --set-option=[SECT:]VAR=VAL Set configuration variable (repeatable).\n\
1364 -O, --output=FILE|DIR Store image(s) in FILE or DIR.\n\
1365 -R, --remove-other Delete image files for other Lisp systems.\n\
1366 -U, --remove-unknown Delete unrecognized files in image dir.\n\
1367 -a, --all-configured Select all configured implementations.\n\
1368 -f, --force Dump images even if they already exist.\n\
1369 -i, --check-installed Check Lisp systems exist before dumping.\n\
1370 -j, --jobs=NJOBS Run up to NJOBS jobs in parallel.\n\
1371 -r, --remove-image Delete image files, instead of creating.\n",
1375 static void show_job_list(const char *what
, struct job
*job
)
1377 struct dstr d
= DSTR_INIT
;
1381 for (; job
; job
= job
->next
) {
1382 if (first
) first
= 0;
1383 else dstr_puts(&d
, ", ");
1384 dstr_putf(&d
, "`%s'", JOB_NAME(job
));
1386 if (first
) dstr_puts(&d
, "(none)");
1388 moan("%s: %s", what
, d
.p
);
1392 int main(int argc
, char *argv
[])
1394 struct config_section_iter si
;
1395 struct config_section
*sect
;
1396 struct config_var
*var
;
1397 const char *out
= 0, *p
, *q
, *l
;
1400 struct dstr d
= DSTR_INIT
;
1407 /* Command-line options. */
1408 static const struct option opts
[] = {
1409 { "help", 0, 0, 'h' },
1410 { "version", 0, 0, 'V' },
1411 { "output", OPTF_ARGREQ
, 0, 'O' },
1412 { "remove-other", OPTF_NEGATE
, 0, 'R' },
1413 { "remove-unknown", OPTF_NEGATE
, 0, 'U' },
1414 { "all-configured", 0, 0, 'a' },
1415 { "config-file", OPTF_ARGREQ
, 0, 'c' },
1416 { "force", OPTF_NEGATE
, 0, 'f' },
1417 { "check-installed", OPTF_NEGATE
, 0, 'i' },
1418 { "jobs", OPTF_ARGREQ
, 0, 'j' },
1419 { "dry-run", OPTF_NEGATE
, 0, 'n' },
1420 { "set-option", OPTF_ARGREQ
, 0, 'o' },
1421 { "quiet", 0, 0, 'q' },
1422 { "remove-image", OPTF_NEGATE
, 0, 'r' },
1423 { "verbose", 0, 0, 'v' },
1427 /* Initial setup. */
1428 set_progname(argv
[0]);
1432 /* Parse the options. */
1433 optprog
= (/*unconst*/ char *)progname
;
1435 #define FLAGOPT(ch, f) \
1439 case ch | OPTF_NEGATED: \
1444 i
= mdwopt(argc
- 1, argv
+ 1, "hVO:R+U+ac:f+i+j:n+o:qr+v", opts
, 0, 0,
1445 OPTF_NEGATION
| OPTF_NOPROGNAME
);
1448 case 'h': help(stdout
); exit(0);
1449 case 'V': version(stdout
); exit(0);
1450 case 'O': out
= optarg
; break;
1451 FLAGOPT('R', AF_CLEAN
);
1452 FLAGOPT('U', AF_JUNK
);
1453 case 'a': flags
|= AF_ALL
; break;
1454 case 'c': read_config_path(optarg
, 0); flags
|= AF_SETCONF
; break;
1455 FLAGOPT('f', AF_FORCE
);
1456 FLAGOPT('i', AF_CHECKINST
);
1457 case 'j': maxrun
= parse_int("number of jobs", optarg
, 1, 65535); break;
1458 FLAGOPT('n', AF_DRYRUN
);
1459 case 'o': if (set_config_var(optarg
)) flags
|= AF_BOGUS
; break;
1460 case 'q': if (verbose
) verbose
--; break;
1461 FLAGOPT('r', AF_REMOVE
);
1462 case 'v': verbose
++; break;
1463 default: flags
|= AF_BOGUS
; break;
1469 /* CHeck that everything worked. */
1471 if ((flags
&AF_ALL
) ? optind
< argc
: optind
>= argc
) flags
|= AF_BOGUS
;
1472 if (flags
&AF_BOGUS
) { usage(stderr
); exit(127); }
1474 /* Load default configuration if no explicit files were requested. */
1475 if (!(flags
&AF_SETCONF
)) load_default_config();
1477 /* OK, so we've probably got some work to do. Let's set things up ready.
1478 * It'll be annoying if our standard descriptors aren't actually set up
1479 * properly, so we'll make sure those slots are populated. We'll need a
1480 * `/dev/null' descriptor anyway (to be stdin for the jobs). We'll also
1481 * need a temporary directory, and it'll be less temporary if we don't
1482 * arrange to delete it when we're done. And finally we'll need to know
1483 * when a child process exits.
1486 fd
= open("/dev/null", O_RDWR
);
1487 if (fd
< 0) lose("failed to open `/dev/null': %s", strerror(errno
));
1488 if (fd
> 2) { nullfd
= fd
; break; }
1490 configure_fd("null fd", nullfd
, 0, 1);
1493 lose("failed to create signal pipe: %s", strerror(errno
));
1494 configure_fd("signal pipe (read end)", sig_pipe
[0], 1, 1);
1495 configure_fd("signal pipe (write end)", sig_pipe
[1], 1, 1);
1496 sigemptyset(&caught
); sigemptyset(&pending
);
1497 set_signal_handler("SIGTERM", SIGTERM
, SIGF_IGNOK
);
1498 set_signal_handler("SIGINT", SIGINT
, SIGF_IGNOK
);
1499 set_signal_handler("SIGHUP", SIGHUP
, SIGF_IGNOK
);
1500 set_signal_handler("SIGCHLD", SIGCHLD
, 0);
1502 /* Create the temporary directory and export it into the configuration. */
1504 config_set_var(&config
, builtin
, CF_LITERAL
, "@%tmp-dir", tmpdir
);
1505 config_set_var(&config
, builtin
, 0,
1506 "@tmp-dir", "${@BUILTIN:@%tmp-dir}/${@name}");
1508 /* Work out where the image files are going to go. If there's no `-O'
1509 * option then we use the main `image-dir'. Otherwise what happens depends
1510 * on whether this is a file or a directory.
1513 config_set_var(&config
, builtin
, 0,
1514 "@image-link", "${@image-dir}/${image-file}");
1515 var
= config_find_var(&config
, builtin
, CF_INHERIT
, "@image-dir");
1516 assert(var
); out
= config_subst_var_alloc(&config
, builtin
, var
);
1517 } else if (!stat(out
, &st
) && S_ISDIR(st
.st_mode
)) {
1518 config_set_var(&config
, builtin
, CF_LITERAL
, "@%out-dir", out
);
1519 config_set_var(&config
, builtin
, 0,
1520 "@image-link", "${@BUILTIN:@%out-dir}/${image-file}");
1521 } else if (argc
- optind
!= 1)
1522 lose("can't dump multiple Lisps to a single output file");
1523 else if (flags
&AF_JUNK
)
1524 lose("can't clear junk in a single output file");
1525 else if (flags
&AF_CLEAN
)
1526 lose("can't clean other images with a single output file");
1528 config_set_var(&config
, builtin
, CF_LITERAL
, "@image-link", out
);
1530 /* Set the staging and versioned filenames. */
1531 config_set_var(&config
, builtin
, 0,
1532 "@image-out", "${@image-link}-${@hash}");
1533 config_set_var(&config
, builtin
, 0, "@image-new", "${@image-out}.new");
1534 config_set_var(&config
, builtin
, 0,
1535 "@image-newlink", "${@image-link}.new");
1537 config_set_var(&config
, builtin
, 0, "@script",
1538 "${@ENV:RUNLISP_EVAL?"
1539 "${@CONFIG:eval-script?"
1540 "${@data-dir}/eval.lisp}}");
1542 /* Configure an initial value for `@hash'. This is necessary so that
1543 * `add_job' can expand `dump-image' to check that the command exists.
1545 config_set_var(&config
, builtin
, CF_LITERAL
, "@hash", "!!!unset!!!");
1547 /* Dump the final configuration if we're being very verbose. */
1548 if (verbose
>= 5) dump_config();
1550 /* There are a number of different strategies we might employ, depending on
1551 * the exact request.
1554 * REMOVE CLEAN JUNK selected others junk?
1556 * * nil nil ready/delete -- no
1557 * * nil t ready/delete none yes
1558 * nil t nil ready delete no
1559 * nil t t ready -- yes
1560 * t t nil -- delete no
1564 /* First step: if `AF_REMOVE' and `AF_CLEAN' are not both set, then scan
1565 * the selected Lisp systems and add them to the appropriate queue.
1567 * Bit-hack: if they are not both set, then their complements are not both
1570 if (~flags
&(AF_REMOVE
| AF_CLEAN
)) {
1572 /* Determine the flags for `add_job' when we select the Lisp systems. If
1573 * we intend to clear junk then we must notice the image names we
1574 * encounter. If we're supposed to check that Lisps exist before dumping
1575 * then do that -- but it doesn't make any sense for deletion.
1577 f
= flags
&AF_REMOVE ? JQ_DELETE
: JQ_READY
;
1578 if (flags
&AF_JUNK
) f
|= JF_NOTICE
;
1579 if (flags
&AF_CHECKINST
) f
|= JF_CHECKINST
;
1580 if (!(flags
&(AF_FORCE
| AF_REMOVE
))) f
|= JF_CHECKEXIST
;
1582 /* If we have named Lisps, then process them. */
1583 if (!(flags
&AF_ALL
))
1584 for (i
= optind
; i
< argc
; i
++)
1585 add_named_job(f
, argv
[i
], strlen(argv
[i
]));
1587 /* Otherwise we're supposed to dump `all' of them. If there's a `dump'
1588 * configuration setting then we need to parse that. Otherwise we just
1592 var
= config_find_var(&config
, toplevel
, CF_INHERIT
, "dump");
1594 /* No setting. Just do all of the Lisps which look available. */
1597 for (config_start_section_iter(&config
, &si
);
1598 (sect
= config_next_section(&si
)); )
1601 /* Parse the `dump' list. */
1603 dstr_reset(&d
); config_subst_var(&config
, toplevel
, var
, &d
);
1604 p
= d
.p
; l
= p
+ d
.len
;
1606 while (p
< l
&& ISSPACE(*p
)) p
++;
1609 while (p
< l
&& !ISSPACE(*p
) && *p
!= ',') p
++;
1610 add_named_job(f
, q
, p
- q
);
1611 while (p
< l
&& ISSPACE(*p
)) p
++;
1612 if (p
< l
&& *p
== ',') p
++;
1618 /* Second step: if exactly one of `AF_CLEAN' and `AF_JUNK' is set, then we
1619 * need to scan all of the remaining Lisps and add them to the `delete'
1622 if (!(flags
&AF_CLEAN
) != !(flags
&AF_JUNK
)) {
1624 /* Determine the flag settings. If we're junking, then we're not
1625 * cleaning -- we just want to mark images belonging to other Lisps as
1626 * off-limits to the junking scan.
1628 f
= flags
&AF_CLEAN ? JQ_DELETE
: JQ_NONE
| JF_NOTICE
;
1630 /* Now scan the Lisp systems. */
1631 for (config_start_section_iter(&config
, &si
);
1632 (sect
= config_next_section(&si
)); )
1636 /* Terminate the job queues. */
1637 *job_ready_tail
= 0;
1638 *job_delete_tail
= 0;
1640 /* Report on what it is we're about to do. */
1642 show_job_list("dumping Lisp images", job_ready
);
1643 show_job_list("deleting Lisp images", job_delete
);
1646 /* If there turns out to be nothing to do, then mention this. */
1647 if (!(flags
&AF_REMOVE
) && verbose
>= 2 && !job_ready
)
1648 moan("no Lisp images to dump");
1650 /* Run the dumping jobs. */
1653 /* Check for any last signals. If we hit any fatal signals then we should
1654 * kill ourselves so that the exit status will be right.
1657 if (sigloss
) { cleanup(); signal(sigloss
, SIG_DFL
); raise(sigloss
); }
1659 /* Now delete Lisps which need deleting. */
1660 while (job_delete
) {
1661 job
= job_delete
; job_delete
= job
->next
;
1662 if (flags
&AF_DRYRUN
) {
1664 moan("not deleting `%s' image link `%s' (dry run)",
1665 JOB_NAME(job
), job
->imglink
);
1666 if (job
->oldimg
&& verbose
>= 2)
1667 moan("not deleting `%s' image `%s' (dry run)",
1668 JOB_NAME(job
), job
->oldimg
);
1671 moan("deleting `%s' image `%s'",
1672 JOB_NAME(job
), job
->imglink
);
1673 if (unlink(job
->imglink
) && errno
!= ENOENT
)
1674 bad("failed to delete `%s' image link `%s': %s",
1675 JOB_NAME(job
), job
->imglink
, strerror(errno
));
1676 if (job
->oldimg
&& unlink(job
->oldimg
) && errno
!= ENOENT
)
1677 bad("failed to delete `%s' image `%s': %s",
1678 JOB_NAME(job
), job
->oldimg
, strerror(errno
));
1682 /* Finally, maybe delete all of the junk files in the image directory. */
1683 if (flags
&AF_JUNK
) {
1686 lose("failed to open image directory `%s': %s", out
, strerror(errno
));
1688 dstr_puts(&d
, out
); dstr_putc(&d
, '/'); o
= d
.len
;
1690 moan("cleaning up junk in image directory `%s'", out
);
1692 de
= readdir(dir
); if (!de
) break;
1693 if (de
->d_name
[0] == '.' &&
1694 (!de
->d_name
[1] || (de
->d_name
[1] == '.' && !de
->d_name
[2])))
1696 n
= strlen(de
->d_name
);
1697 d
.len
= o
; dstr_putm(&d
, de
->d_name
, n
+ 1);
1698 if (!treap_lookup(&good
, de
->d_name
, n
)) {
1699 if (flags
&AF_DRYRUN
) {
1701 moan("not deleting junk file `%s' (dry run)", d
.p
);
1704 moan("deleting junk file `%s'", d
.p
);
1705 if (unlink(d
.p
) && errno
!= ENOENT
)
1706 bad("failed to delete junk file `%s': %s", d
.p
, strerror(errno
));
1716 /*----- That's all, folks -------------------------------------------------*/