| 1 | /* -*-c-*- |
| 2 | * |
| 3 | * Invoke Lisp scripts and implementations |
| 4 | * |
| 5 | * (c) 2020 Mark Wooding |
| 6 | */ |
| 7 | |
| 8 | /*----- Licensing notice --------------------------------------------------* |
| 9 | * |
| 10 | * This file is part of Runlisp, a tool for invoking Common Lisp scripts. |
| 11 | * |
| 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. |
| 16 | * |
| 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 |
| 20 | * for more details. |
| 21 | * |
| 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/>. |
| 24 | */ |
| 25 | |
| 26 | /*----- Header files ------------------------------------------------------*/ |
| 27 | |
| 28 | #include "config.h" |
| 29 | |
| 30 | #include <ctype.h> |
| 31 | #include <errno.h> |
| 32 | #include <stdio.h> |
| 33 | #include <stdlib.h> |
| 34 | #include <string.h> |
| 35 | |
| 36 | #include "common.h" |
| 37 | #include "lib.h" |
| 38 | #include "mdwopt.h" |
| 39 | |
| 40 | /*----- Static data -------------------------------------------------------*/ |
| 41 | |
| 42 | struct lispsys { |
| 43 | struct treap_node _node; |
| 44 | struct lispsys *next_lisp, *next_accept, *next_prefer, *next_order; |
| 45 | unsigned f; |
| 46 | #define LF_KNOWN 1u |
| 47 | #define LF_ACCEPT 2u |
| 48 | #define LF_PREFER 4u |
| 49 | struct config_section *sect; |
| 50 | struct config_var *var; |
| 51 | }; |
| 52 | #define LISPSYS_NAME(lisp) TREAP_NODE_KEY(lisp) |
| 53 | #define LISPSYS_NAMELEN(lisp) TREAP_NODE_KEYLEN(lisp) |
| 54 | |
| 55 | struct lispsys_list { |
| 56 | struct lispsys *head, **tail; |
| 57 | }; |
| 58 | |
| 59 | static struct argv argv_tail = ARGV_INIT; |
| 60 | const char *script = 0; |
| 61 | |
| 62 | static unsigned flags = 0; |
| 63 | #define AF_CMDLINE 0x0000u |
| 64 | #define AF_EMBED 0x0001u |
| 65 | #define AF_ENV 0x0002u |
| 66 | #define AF_CONF 0x0003u |
| 67 | #define AF_STATEMASK 0x000fu |
| 68 | #define AF_BOGUS 0x0010u |
| 69 | #define AF_SETCONF 0x0020u |
| 70 | #define AF_NOEMBED 0x0040u |
| 71 | #define AF_DRYRUN 0x0080u |
| 72 | #define AF_VANILLA 0x0100u |
| 73 | |
| 74 | struct treap lispsys = TREAP_INIT; |
| 75 | static struct lispsys_list |
| 76 | lisps = { 0, &lisps.head }, |
| 77 | accept = { 0, &accept.head }, |
| 78 | prefer = { 0, &prefer.head }; |
| 79 | |
| 80 | /*----- Main code ---------------------------------------------------------*/ |
| 81 | |
| 82 | static void version(FILE *fp) |
| 83 | { fprintf(fp, "%s, version %s\n", progname, PACKAGE_VERSION); } |
| 84 | |
| 85 | static void usage(FILE *fp) |
| 86 | { |
| 87 | fprintf(fp, "\ |
| 88 | usage:\n\ |
| 89 | %s [OPTIONS] [--] SCRIPT [ARGUMENTS ...]\n\ |
| 90 | %s [OPTIONS] [-e EXPR] [-p EXPR] [-l FILE] [--] [ARGUMENTS ...]\n\ |
| 91 | OPTIONS:\n\ |
| 92 | [-CDEnqv] [+DEn] [-L SYS,SYS,...] [-c CONF] [-o [SECT:]VAR=VAL]\n", |
| 93 | progname, progname); |
| 94 | } |
| 95 | |
| 96 | static void help(FILE *fp) |
| 97 | { |
| 98 | version(fp); fputc('\n', fp); usage(fp); |
| 99 | fputs("\n\ |
| 100 | Help options:\n\ |
| 101 | -h, --help Show this help text and exit successfully.\n\ |
| 102 | -V, --version Show version number and exit successfully.\n\ |
| 103 | \n\ |
| 104 | Diagnostics:\n\ |
| 105 | -n, --dry-run Don't run run anything (useful with `-v').\n\ |
| 106 | -q, --quiet Don't print warning messages.\n\ |
| 107 | -v, --verbose Print informational messages (repeatable).\n\ |
| 108 | \n\ |
| 109 | Configuration:\n\ |
| 110 | -E, --command-line-only Don't read embedded options from script.\n\ |
| 111 | -c, --config-file=CONF Read configuration from CONF (repeatable).\n\ |
| 112 | -o, --set-option=[SECT:]VAR=VAL Set configuration variable (repeatable).\n\ |
| 113 | \n\ |
| 114 | Lisp implementation selection:\n\ |
| 115 | -D, --vanilla-image Run vanilla Lisp images, not custom ones.\n\ |
| 116 | -L, --accept-lisp=SYS,SYS,... Only use the listed Lisp systems.\n\ |
| 117 | \n\ |
| 118 | Evaluation mode:\n\ |
| 119 | -e, --evaluate-expression=EXPR Evaluate EXPR for effect (repeatable).\n\ |
| 120 | -l, --load-file=FILE Load FILE (repeatable).\n\ |
| 121 | -p, --print-expression=EXPR Print (`prin1') EXPR (repeatable).\n", |
| 122 | fp); |
| 123 | } |
| 124 | |
| 125 | static struct lispsys *ensure_lispsys(const char *name, size_t n) |
| 126 | { |
| 127 | struct lispsys *lisp; |
| 128 | struct treap_path path; |
| 129 | |
| 130 | lisp = treap_probe(&lispsys, name, n, &path); |
| 131 | if (!lisp) { |
| 132 | lisp = xmalloc(sizeof(*lisp)); |
| 133 | lisp->f = 0; lisp->sect = 0; |
| 134 | treap_insert(&lispsys, &path, &lisp->_node, name, n); |
| 135 | } |
| 136 | return (lisp); |
| 137 | } |
| 138 | |
| 139 | #define LISP_LINK(lisp, linkoff) \ |
| 140 | ((struct lispsys **)((unsigned char *)(lisp) + (linkoff))) |
| 141 | |
| 142 | static void add_lispsys(const char *p, const char *what, |
| 143 | struct lispsys_list *list, |
| 144 | unsigned flag, size_t linkoff) |
| 145 | { |
| 146 | struct lispsys *lisp, **link; |
| 147 | const char *q; |
| 148 | |
| 149 | if (!*p) return; |
| 150 | for (;;) { |
| 151 | if (!*p) break; |
| 152 | q = p; while (*p && *p != ',') p++; |
| 153 | lisp = ensure_lispsys(q, p - q); |
| 154 | if (lisp->f&flag) { |
| 155 | if (verbose >= 1) |
| 156 | moan("ignoring duplicate %s Lisp `%.*s'", what, (int)(p - q), q); |
| 157 | } else { |
| 158 | link = LISP_LINK(lisp, linkoff); |
| 159 | lisp->f |= flag; *link = 0; |
| 160 | *list->tail = lisp; list->tail = link; |
| 161 | } |
| 162 | if (!*p) break; |
| 163 | p++; |
| 164 | } |
| 165 | } |
| 166 | |
| 167 | static void check_lisps(const char *what, |
| 168 | struct lispsys_list *list, size_t linkoff) |
| 169 | { |
| 170 | struct lispsys *lisp; |
| 171 | |
| 172 | for (lisp = list->head; lisp; lisp = *LISP_LINK(lisp, linkoff)) |
| 173 | if (!(lisp->f&LF_KNOWN)) |
| 174 | lose("unknown Lisp implementation `%s'", LISPSYS_NAME(lisp)); |
| 175 | } |
| 176 | |
| 177 | static void dump_lisps(const char *what, |
| 178 | struct lispsys_list *list, size_t linkoff) |
| 179 | { |
| 180 | struct dstr d = DSTR_INIT; |
| 181 | struct lispsys *lisp; |
| 182 | int first; |
| 183 | |
| 184 | first = 1; |
| 185 | for (lisp = list->head; lisp; lisp = *LISP_LINK(lisp, linkoff)) { |
| 186 | if (first) first = 0; |
| 187 | else dstr_puts(&d, ", "); |
| 188 | dstr_putf(&d, "`%s'", LISPSYS_NAME(lisp)); |
| 189 | } |
| 190 | if (first) dstr_puts(&d, "(none)"); |
| 191 | dstr_putz(&d); |
| 192 | moan("%s: %s", what, d.p); |
| 193 | dstr_release(&d); |
| 194 | } |
| 195 | |
| 196 | static void push_eval_op(char op, const char *val) |
| 197 | { |
| 198 | char *p; |
| 199 | size_t n; |
| 200 | |
| 201 | if ((flags&AF_STATEMASK) != AF_CMDLINE) { |
| 202 | moan("must use `-e', `-p', or `-l' on command line"); |
| 203 | flags |= AF_BOGUS; |
| 204 | return; |
| 205 | } |
| 206 | |
| 207 | n = strlen(val) + 1; |
| 208 | p = xmalloc(n + 1); |
| 209 | p[0] = op; memcpy(p + 1, val, n); |
| 210 | argv_append(&argv_tail, p); |
| 211 | } |
| 212 | |
| 213 | static void parse_options(int argc, char *argv[]) |
| 214 | { |
| 215 | int i; |
| 216 | |
| 217 | static const struct option opts[] = { |
| 218 | { "help", 0, 0, 'h' }, |
| 219 | { "version", 0, 0, 'V' }, |
| 220 | { "vanilla-image", OPTF_NEGATE, 0, 'D' }, |
| 221 | { "command-line-only", OPTF_NEGATE, 0, 'E' }, |
| 222 | { "accept-lisp", OPTF_ARGREQ, 0, 'L' }, |
| 223 | { "config-file", OPTF_ARGREQ, 0, 'c' }, |
| 224 | { "evaluate-expression", OPTF_ARGREQ, 0, 'e' }, |
| 225 | { "load-file", OPTF_ARGREQ, 0, 'l' }, |
| 226 | { "dry-run", OPTF_NEGATE, 0, 'n' }, |
| 227 | { "set-option", OPTF_ARGREQ, 0, 'o' }, |
| 228 | { "print-expression", OPTF_ARGREQ, 0, 'p' }, |
| 229 | { "quiet", 0, 0, 'q' }, |
| 230 | { "verbose", 0, 0, 'v' }, |
| 231 | { 0, 0, 0, 0 } |
| 232 | }; |
| 233 | |
| 234 | optarg = 0; optind = 0; optprog = (/*unconst*/ char *)progname; |
| 235 | for (;;) { |
| 236 | i = mdwopt(argc, argv, "+hVD+E+L:c:e:l:n+o:p:qv", opts, 0, 0, |
| 237 | OPTF_NEGATION | OPTF_NOPROGNAME); |
| 238 | if (i < 0) break; |
| 239 | switch (i) { |
| 240 | case 'h': help(stdout); exit(0); |
| 241 | case 'V': version(stdout); exit(0); |
| 242 | case 'D': flags |= AF_VANILLA; break; |
| 243 | case 'D' | OPTF_NEGATED: flags &= ~AF_VANILLA; break; |
| 244 | case 'E': flags |= AF_NOEMBED; break; |
| 245 | case 'E' | OPTF_NEGATED: flags &= ~AF_NOEMBED; break; |
| 246 | case 'L': |
| 247 | add_lispsys(optarg, "acceptable", &accept, LF_ACCEPT, |
| 248 | offsetof(struct lispsys, next_accept)); |
| 249 | break; |
| 250 | case 'c': read_config_path(optarg, 0); flags |= AF_SETCONF; break; |
| 251 | case 'e': push_eval_op('!', optarg); break; |
| 252 | case 'l': push_eval_op('<', optarg); break; |
| 253 | case 'n': flags |= AF_DRYRUN; break; |
| 254 | case 'n' | OPTF_NEGATED: flags &= ~AF_DRYRUN; break; |
| 255 | case 'o': if (set_config_var(optarg)) flags |= AF_BOGUS; break; |
| 256 | case 'p': push_eval_op('?', optarg); break; |
| 257 | case 'q': if (verbose) verbose--; break; |
| 258 | case 'v': verbose++; break; |
| 259 | default: flags |= AF_BOGUS; break; |
| 260 | } |
| 261 | } |
| 262 | } |
| 263 | |
| 264 | static void handle_embedded_args(const char *script) |
| 265 | { |
| 266 | struct dstr d = DSTR_INIT; |
| 267 | struct argv av = ARGV_INIT; |
| 268 | char *p, *q, *r; const char *l; |
| 269 | size_t n; |
| 270 | int qstate = 0; |
| 271 | FILE *fp = 0; |
| 272 | |
| 273 | fp = fopen(script, "r"); |
| 274 | if (!fp) lose("can't read script `%s': %s", script, strerror(errno)); |
| 275 | |
| 276 | if (dstr_readline(&d, fp)) goto end; |
| 277 | dstr_reset(&d); if (dstr_readline(&d, fp)) goto end; |
| 278 | |
| 279 | p = strstr(d.p, "@RUNLISP:"); if (!p) goto end; |
| 280 | p += 9; q = p; l = d.p + d.len; |
| 281 | for (;;) { |
| 282 | while (p < l && ISSPACE(*p)) p++; |
| 283 | if (p >= l) break; |
| 284 | if (l - p >= 3 && p[0] == '-' && p[1] == '*' && p[2] == '-') { |
| 285 | p = strstr(p + 3, "-*-"); |
| 286 | if (!p || p + 3 > l) |
| 287 | lose("%s:2: unfinished local-variables list", script); |
| 288 | p += 3; |
| 289 | continue; |
| 290 | } |
| 291 | if (l - p >= 2 && p[0] == '-' && p[1] == '-' && |
| 292 | (l == p + 2 || ISSPACE(p[2]))) |
| 293 | break; |
| 294 | |
| 295 | argv_append(&av, q); |
| 296 | while (p < l && (qstate || !ISSPACE(*p))) { |
| 297 | if (*p == '"') { p++; qstate = !qstate; } |
| 298 | else if (*p == '\\') { |
| 299 | p++; if (p >= l) lose("%s:2: unfinished `\\' escape", script); |
| 300 | *q++ = *p++; |
| 301 | } else if (*p == '\'') { |
| 302 | p++; r = strchr(p, '\''); |
| 303 | if (!r || r > l) lose("%s:2: missing `''", script); |
| 304 | n = r - p; memmove(q, p, n); q += n; p = r + 1; |
| 305 | } else { |
| 306 | n = strcspn(p, qstate ? "\"\\" : "\"'\\ \f\n\r\t\v"); |
| 307 | if (n > l - p) n = l - p; |
| 308 | memmove(q, p, n); q += n; p += n; |
| 309 | } |
| 310 | } |
| 311 | if (qstate) lose("%s:2: missing `\"'", script); |
| 312 | if (p < l) p++; |
| 313 | *q++ = 0; |
| 314 | } |
| 315 | |
| 316 | flags = (flags&~AF_STATEMASK) | AF_EMBED; |
| 317 | parse_options(av.n, (char * /*unconst*/*)av.v); |
| 318 | if (optind < av.n) |
| 319 | lose("%s:2: positional argument `%s' not permitted here", |
| 320 | script, av.v[optind]); |
| 321 | |
| 322 | end: |
| 323 | if (fp) { |
| 324 | if (ferror(fp)) |
| 325 | lose("error reading script `%s': %s", script, strerror(errno)); |
| 326 | fclose(fp); |
| 327 | } |
| 328 | dstr_release(&d); argv_release(&av); |
| 329 | } |
| 330 | |
| 331 | int main(int argc, char *argv[]) |
| 332 | { |
| 333 | struct config_section_iter si; |
| 334 | struct config_section *sect; |
| 335 | struct config_var *var; |
| 336 | struct lispsys_list order; |
| 337 | struct lispsys *lisp, **tail; |
| 338 | struct dstr d = DSTR_INIT; |
| 339 | struct argv av = ARGV_INIT; |
| 340 | |
| 341 | set_progname(argv[0]); |
| 342 | |
| 343 | init_config(); |
| 344 | config_set_var(&config, toplevel, 0, "prefer", "${@ENV:RUNLISP_PREFER?}"); |
| 345 | |
| 346 | flags = (flags&~AF_STATEMASK) | AF_CMDLINE; |
| 347 | parse_options(argc - 1, argv + 1); optind++; |
| 348 | |
| 349 | if (argv_tail.n) |
| 350 | flags |= AF_NOEMBED; |
| 351 | else if (!script && !argv_tail.n) { |
| 352 | if (optind < argc) script = argv[optind]++; |
| 353 | else flags |= AF_BOGUS; |
| 354 | } |
| 355 | |
| 356 | argc -= optind; argv += optind; |
| 357 | if (argv_tail.n) { |
| 358 | argv_append(&argv_tail, "--"); |
| 359 | argv_appendn(&argv_tail, (const char *const *)argv, argc); |
| 360 | argc = argv_tail.n; argv = (/*unconst*/ char */*unconst*/ *)argv_tail.v; |
| 361 | } |
| 362 | |
| 363 | if (flags&AF_BOGUS) { usage(stderr); exit(2); } |
| 364 | if (!(flags&AF_NOEMBED)) handle_embedded_args(script); |
| 365 | if (!(flags&AF_SETCONF)) load_default_config(); |
| 366 | if (verbose >= 5) dump_config(); |
| 367 | |
| 368 | dstr_reset(&d); |
| 369 | var = config_find_var(&config, toplevel, CF_INHERIT, "prefer"); |
| 370 | config_subst_var(&config, toplevel, var, &d); |
| 371 | add_lispsys(d.p, "preferred", &prefer, LF_PREFER, |
| 372 | offsetof(struct lispsys, next_prefer)); |
| 373 | |
| 374 | if (!script) |
| 375 | script = config_subst_string_alloc |
| 376 | (&config, common, "<internal>", |
| 377 | "${@ENV:RUNLISP_EVAL?${@CONFIG:data-dir}/eval.lisp}"); |
| 378 | |
| 379 | if (setenv("__CL_ARGV0", script, 1)) |
| 380 | lose("failed to set script-name environment variable"); |
| 381 | config_set_var(&config, builtin, CF_LITERAL, "@SCRIPT", script); |
| 382 | |
| 383 | tail = lisps.tail; |
| 384 | for (config_start_section_iter(&config, &si); |
| 385 | (sect = config_next_section(&si)); ) { |
| 386 | var = config_find_var(&config, sect, CF_INHERIT, "run-script"); |
| 387 | if (!var) continue; |
| 388 | lisp = ensure_lispsys(CONFIG_SECTION_NAME(sect), |
| 389 | CONFIG_SECTION_NAMELEN(sect)); |
| 390 | lisp->f |= LF_KNOWN; lisp->sect = sect; lisp->var = var; |
| 391 | *tail = lisp; tail = &lisp->next_lisp; |
| 392 | } |
| 393 | *tail = 0; lisps.tail = tail; |
| 394 | |
| 395 | check_lisps("acceptable", &accept, offsetof(struct lispsys, next_accept)); |
| 396 | check_lisps("preferred", &prefer, offsetof(struct lispsys, next_prefer)); |
| 397 | |
| 398 | if (!accept.head) { |
| 399 | if (verbose >= 2) |
| 400 | moan("no explicitly acceptable implementations: allowing all"); |
| 401 | tail = accept.tail; |
| 402 | for (lisp = lisps.head; lisp; lisp = lisp->next_lisp) |
| 403 | { lisp->f |= LF_ACCEPT; *tail = lisp; tail = &lisp->next_accept; } |
| 404 | *tail = 0; accept.tail = tail; |
| 405 | } |
| 406 | |
| 407 | tail = &order.head; |
| 408 | for (lisp = prefer.head; lisp; lisp = lisp->next_prefer) |
| 409 | if (lisp->f&LF_ACCEPT) { *tail = lisp; tail = &lisp->next_order; } |
| 410 | for (lisp = accept.head; lisp; lisp = lisp->next_accept) |
| 411 | if (!(lisp->f&LF_PREFER)) { *tail = lisp; tail = &lisp->next_order; } |
| 412 | *tail = 0; |
| 413 | |
| 414 | if (verbose >= 4) |
| 415 | dump_lisps("known Lisps", &lisps, offsetof(struct lispsys, next_lisp)); |
| 416 | if (verbose >= 3) { |
| 417 | dump_lisps("acceptable Lisps", &accept, |
| 418 | offsetof(struct lispsys, next_accept)); |
| 419 | dump_lisps("preferred Lisps", &prefer, |
| 420 | offsetof(struct lispsys, next_prefer)); |
| 421 | dump_lisps("overall preference order", &order, |
| 422 | offsetof(struct lispsys, next_order)); |
| 423 | } |
| 424 | |
| 425 | for (lisp = order.head; lisp; lisp = lisp->next_order) { |
| 426 | if (config_find_var(&config, lisp->sect, CF_INHERIT, "image-file")) { |
| 427 | var = config_find_var(&config, lisp->sect, CF_INHERIT, "image-path"); |
| 428 | dstr_reset(&d); config_subst_var(&config, lisp->sect, var, &d); |
| 429 | if (file_exists_p(d.p, verbose >= 2 ? FEF_VERBOSE : 0)) |
| 430 | config_set_var(&config, lisp->sect, CF_LITERAL, "@IMAGE", "t"); |
| 431 | } |
| 432 | argv_reset(&av); |
| 433 | config_subst_split_var(&config, lisp->sect, lisp->var, &av); |
| 434 | if (!av.n) { |
| 435 | moan("empty command for Lisp implementation `%s'", LISPSYS_NAME(lisp)); |
| 436 | continue; |
| 437 | } |
| 438 | argv_appendn(&av, (const char *const *)argv, argc); |
| 439 | if (!try_exec(&av, |
| 440 | (flags&AF_DRYRUN ? TEF_DRYRUN : 0) | |
| 441 | (verbose >= 2 ? TEF_VERBOSE : 0))) |
| 442 | return (0); |
| 443 | } |
| 444 | |
| 445 | lose("no acceptable Lisp systems found"); |
| 446 | } |
| 447 | |
| 448 | /*----- That's all, folks -------------------------------------------------*/ |