861345b4 |
1 | ;;; -*-lisp-*- |
2 | ;;; |
3 | ;;; $Id$ |
4 | ;;; |
5 | ;;; Option parser, standard issue |
6 | ;;; |
7 | ;;; (c) 2005 Straylight/Edgeware |
8 | ;;; |
9 | |
10 | ;;;----- Licensing notice --------------------------------------------------- |
11 | ;;; |
12 | ;;; This program is free software; you can redistribute it and/or modify |
13 | ;;; it under the terms of the GNU General Public License as published by |
14 | ;;; the Free Software Foundation; either version 2 of the License, or |
15 | ;;; (at your option) any later version. |
16 | ;;; |
17 | ;;; This program is distributed in the hope that it will be useful, |
18 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
19 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
20 | ;;; GNU General Public License for more details. |
21 | ;;; |
22 | ;;; You should have received a copy of the GNU General Public License |
23 | ;;; along with this program; if not, write to the Free Software Foundation, |
24 | ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
25 | |
26 | (defpackage #:mdw.optparse |
27 | (:use #:common-lisp #:mdw.base #:mdw.sys-base #:mdw.str) |
28 | (:export #:exit #:*program-name* #:*command-line-strings* |
29 | #:moan #:die |
30 | #:option #:optionp #:make-option |
31 | #:opt-short-name #:opt-long-name #:opt-tag #:opt-negated-tag |
32 | #:opt-arg-name #:opt-arg-optional-p #:opt-documentation |
33 | #:option-parser #:make-option-parser #:option-parser-p |
34 | #:op-options #:op-non-option #:op-long-only-p #:op-numeric-p |
35 | #:op-negated-numeric-p #:op-negated-p |
36 | #:option-parse-error |
37 | #:option-parse-remainder #:option-parse-next #:option-parse-try |
38 | #:with-unix-error-reporting |
39 | #:defopthandler #:invoke-option-handler |
40 | #:set #:clear #:inc #:dec #:read #:int #:string |
41 | #:keyword #:list |
42 | #:parse-option-form #:options |
43 | #:simple-usage #:show-usage #:show-version #:show-help |
44 | #:sanity-check-option-list)) |
45 | |
46 | (in-package #:mdw.optparse) |
47 | |
48 | ;;; Standard error-reporting functions. |
49 | |
50 | (defun moan (msg &rest args) |
51 | "Report an error message in the usual way." |
52 | (format *error-output* "~&~A: ~?~%" *program-name* msg args)) |
53 | (defun die (&rest args) |
54 | "Report an error message and exit." |
55 | (apply #'moan args) |
56 | (exit 1)) |
57 | |
58 | ;;; The main option parser. |
59 | |
60 | (defstruct (option (:predicate optionp) |
61 | (:conc-name opt-) |
62 | (:print-function |
63 | (lambda (o s k) |
64 | (declare (ignore k)) |
65 | (format s |
66 | "#<option~@[ -~C,~]~@[ --~A~]~:[~2*~;~:[=~A~;[=~A]~]~]~@[ ~S~]>" |
67 | (opt-short-name o) |
68 | (opt-long-name o) |
69 | (opt-arg-name o) |
70 | (opt-arg-optional-p o) |
71 | (opt-arg-name o) |
72 | (opt-documentation o)))) |
73 | (:constructor %make-option) |
74 | (:constructor make-option |
75 | (long-name |
76 | short-name |
77 | &optional |
78 | arg-name |
79 | &key |
80 | (tag (intern (string-upcase long-name) |
81 | :keyword)) |
82 | negated-tag |
83 | arg-optional-p |
84 | doc |
85 | (documentation doc)))) |
86 | "Describes a command-line option. Slots: |
87 | |
88 | LONG-NAME The option's long name. If this is null, the `option' is |
89 | just a banner to be printed in the program's help text. |
90 | |
91 | TAG The value to be returned if this option is encountered. If |
92 | this is a function, instead, the function is called with the |
93 | option's argument or nil. |
94 | |
95 | NEGATED-TAG As for TAG, but used if the negated form of the option is |
96 | found. If this is nil (the default), the option cannot be |
97 | negated. |
98 | |
99 | SHORT-NAME The option's short name. This must be a single character, or |
100 | nil if the option has no short name. |
101 | |
102 | ARG-NAME The name of the option's argument, a string. If this is nil, |
103 | the option doesn't accept an argument. The name is shown in |
104 | the help text. |
105 | |
106 | ARG-OPTIONAL-P If non-nil, the option's argument is optional. This is |
107 | ignored unless ARG-NAME is non-null. |
108 | |
109 | DOCUMENTATION The help text for this option. It is automatically |
110 | line-wrapped. If nil, the option is omitted from the help |
111 | text. |
112 | |
113 | Usually, one won't use make-option, but use the option macro instead." |
114 | (long-name nil :type (or null string)) |
115 | (tag nil :type t) |
116 | (negated-tag nil :type t) |
117 | (short-name nil :type (or null character)) |
118 | (arg-name nil :type (or null string)) |
119 | (arg-optional-p nil :type t) |
120 | (documentation nil :type (or null string))) |
121 | |
122 | (defstruct (option-parser (:conc-name op-) |
123 | (:constructor make-option-parser |
124 | (argstmp |
125 | options |
126 | &key |
127 | (non-option :skip) |
128 | ((:numericp numeric-p)) |
129 | negated-numeric-p |
130 | long-only-p |
131 | &aux |
132 | (args (cons nil argstmp)) |
133 | (next args) |
134 | (negated-p (or negated-numeric-p |
135 | (some |
136 | #'opt-negated-tag |
137 | options)))))) |
138 | "An option parser object. Slots: |
139 | |
140 | ARGS The arguments to be parsed. Usually this will be |
141 | *command-line-strings*. |
142 | |
143 | OPTIONS List of option structures describing the acceptable options. |
144 | |
145 | NON-OPTION Behaviour when encountering a non-option argument. The |
146 | default is :skip. Allowable values are: |
147 | :skip -- pretend that it appeared after the option |
148 | arguments; this is the default behaviour of GNU getopt |
149 | :stop -- stop parsing options, leaving the remaining |
150 | command line unparsed |
151 | :return -- return :non-option and the argument word |
152 | |
153 | NUMERIC-P Non-nil tag (as for options) if numeric options (e.g., -43) |
154 | are to be allowed. The default is nil. (Anomaly: the |
155 | keyword for this argument is :numericp.) |
156 | |
157 | NEGATED-NUMERIC-P |
158 | Non-nil tag (as for options) if numeric options (e.g., -43) |
159 | can be negated. This is not the same thing as a negative |
160 | numeric option! |
161 | |
162 | LONG-ONLY-P A misnomer inherited from GNU getopt. Whether to allow |
163 | long options to begin with a single dash. Short options are |
164 | still allowed, and may be cuddled as usual. The default is |
165 | nil." |
166 | (args nil :type list) |
167 | (options nil :type list) |
168 | (non-option :skip :type (or function (member :skip :stop :return))) |
169 | (next nil :type list) |
170 | (short-opt nil :type (or null string)) |
171 | (short-opt-index 0 :type fixnum) |
172 | (short-opt-neg-p nil :type t) |
173 | (long-only-p nil :type t) |
174 | (numeric-p nil :type t) |
175 | (negated-numeric-p nil :type t) |
176 | (negated-p nil :type t)) |
177 | |
178 | (define-condition option-parse-error (error simple-condition) |
179 | () |
180 | (:documentation "Indicates an error found while parsing options. Probably |
181 | not that useful.")) |
182 | |
183 | (defun option-parse-error (msg &rest args) |
184 | "Signal an option-parse-error with the given message and arguments." |
185 | (error (make-condition 'option-parse-error |
186 | :format-control msg |
187 | :format-arguments args))) |
188 | |
189 | (defun option-parse-remainder (op) |
190 | "Returns the unparsed remainder of the command line." |
191 | (cdr (op-args op))) |
192 | |
193 | (defun option-parse-next (op) |
194 | "The main option-parsing function. OP is an option-parser object, |
195 | initialized appropriately. Returns two values, OPT and ARG: OPT is the tag |
196 | of the next option read, and ARG is the argument attached to it, or nil if |
197 | there was no argument. If there are no more options, returns nil twice. |
198 | Options whose TAG is a function aren't returned; instead, the tag function is |
199 | called, with the option argument (or nil) as the only argument. It is safe |
200 | for tag functions to throw out of option-parse-next, if they desparately need |
201 | to. (This is the only way to actually get option-parse-next to return a |
202 | function value, should that be what you want.) |
203 | |
204 | While option-parse-next is running, there is a restart `skip-option' which |
205 | moves on to the next option. Error handlers should use this to resume after |
206 | parsing errors." |
207 | (loop |
208 | (labels ((ret (opt &optional arg) |
209 | (return-from option-parse-next (values opt arg))) |
210 | (finished () |
211 | (setf (op-next op) nil) |
212 | (ret nil nil)) |
213 | (peek-arg () |
214 | (cadr (op-next op))) |
215 | (more-args-p () |
216 | (and (op-next op) |
217 | (cdr (op-next op)))) |
218 | (skip-arg () |
219 | (setf (op-next op) (cdr (op-next op)))) |
220 | (eat-arg () |
221 | (setf (cdr (op-next op)) (cddr (op-next op)))) |
222 | (get-arg () |
223 | (prog1 (peek-arg) (eat-arg))) |
224 | (process-option (o name negp &key arg argfunc) |
225 | (cond ((not (opt-arg-name o)) |
226 | (when arg |
227 | (option-parse-error |
228 | "Option `~A' does not accept arguments" |
229 | name))) |
230 | (arg) |
231 | (argfunc |
232 | (setf arg (funcall argfunc))) |
233 | ((opt-arg-optional-p o)) |
234 | ((more-args-p) |
235 | (setf arg (get-arg))) |
236 | (t |
237 | (option-parse-error "Option `~A' requires an argument" |
238 | name))) |
239 | (let ((how (if negp (opt-negated-tag o) (opt-tag o)))) |
240 | (if (functionp how) |
241 | (funcall how arg) |
242 | (ret how arg)))) |
243 | (process-long-option (arg start negp) |
244 | (when (and (not negp) |
245 | (op-negated-p op) |
246 | (> (length arg) (+ start 3)) |
247 | (string= arg "no-" |
248 | :start1 start :end1 (+ start 3))) |
249 | (incf start 3) |
250 | (setf negp t)) |
251 | (let* ((matches nil) |
252 | (eqpos (position #\= arg :start start)) |
253 | (len (or eqpos (length arg))) |
254 | (optname (subseq arg 0 len)) |
255 | (len-2 (- len start))) |
256 | (dolist (o (op-options op)) |
257 | (cond ((or (not (stringp (opt-long-name o))) |
258 | (and negp (not (opt-negated-tag o))) |
259 | (< (length (opt-long-name o)) len-2) |
260 | (string/= optname (opt-long-name o) |
261 | :start1 start :end2 len-2))) |
262 | ((= (length (opt-long-name o)) len-2) |
263 | (setf matches (list o)) |
264 | (return)) |
265 | (t |
266 | (push o matches)))) |
267 | (cond ((null matches) |
268 | (option-parse-error "Unknown option `~A'" optname)) |
269 | ((cdr matches) |
270 | (option-parse-error |
271 | "~ |
272 | Ambiguous long option `~A' -- could be any of:~{~% --~A~}" |
273 | optname |
274 | (mapcar #'opt-long-name matches)))) |
275 | (process-option (car matches) |
276 | optname |
277 | negp |
278 | :arg (and eqpos |
279 | (subseq arg (1+ eqpos))))))) |
280 | (with-simple-restart (skip-option "Skip this bogus option.") |
281 | (cond |
282 | ;; |
283 | ;; We're embroiled in short options: handle them. |
284 | ((op-short-opt op) |
285 | (if (>= (op-short-opt-index op) (length (op-short-opt op))) |
286 | (setf (op-short-opt op) nil) |
287 | (let* ((str (op-short-opt op)) |
288 | (i (op-short-opt-index op)) |
289 | (ch (char str i)) |
290 | (negp (op-short-opt-neg-p op)) |
291 | (name (format nil "~C~A" (if negp #\+ #\-) ch)) |
292 | (o (find ch (op-options op) :key #'opt-short-name))) |
293 | (incf i) |
294 | (setf (op-short-opt-index op) i) |
295 | (when (or (not o) |
296 | (and negp (not (opt-negated-tag o)))) |
297 | (option-parse-error "Unknown option `~A'" name)) |
298 | (process-option o |
299 | name |
300 | negp |
301 | :argfunc |
302 | (and (< i (length str)) |
303 | (lambda () |
304 | (prog1 |
305 | (subseq str i) |
306 | (setf (op-short-opt op) |
307 | nil)))))))) |
308 | ;; |
309 | ;; End of the list. Say we've finished. |
310 | ((not (more-args-p)) |
311 | (finished)) |
312 | ;; |
313 | ;; Process the next option. |
314 | (t |
315 | (let ((arg (peek-arg))) |
316 | (cond |
317 | ;; |
318 | ;; Non-option. Decide what to do. |
319 | ((or (<= (length arg) 1) |
320 | (and (char/= (char arg 0) #\-) |
321 | (or (char/= (char arg 0) #\+) |
322 | (not (op-negated-p op))))) |
323 | (case (op-non-option op) |
324 | (:skip (skip-arg)) |
325 | (:stop (finished)) |
326 | (:return (eat-arg) |
327 | (ret :non-option arg)) |
328 | (t (eat-arg) |
329 | (funcall (op-non-option op) arg)))) |
330 | ;; |
331 | ;; Double-hyphen. Stop right now. |
332 | ((string= arg "--") |
333 | (eat-arg) |
334 | (finished)) |
335 | ;; |
336 | ;; Numbers. Check these before long options, since `--43' is |
337 | ;; not a long option. |
338 | ((and (op-numeric-p op) |
339 | (or (char= (char arg 0) #\-) |
340 | (op-negated-numeric-p op)) |
341 | (or (and (digit-char-p (char arg 1)) |
342 | (every #'digit-char-p (subseq arg 2))) |
343 | (and (or (char= (char arg 1) #\-) |
344 | (char= (char arg 1) #\+)) |
345 | (>= (length arg) 3) |
346 | (digit-char-p (char arg 2)) |
347 | (every #'digit-char-p (subseq arg 3))))) |
348 | (eat-arg) |
349 | (let ((negp (char= (char arg 0) #\+)) |
350 | (num (parse-integer arg :start 1))) |
351 | (when (and negp (eq (op-negated-numeric-p op) :-)) |
352 | (setf num (- num)) |
353 | (setf negp nil)) |
354 | (let ((how (if negp |
355 | (op-negated-numeric-p op) |
356 | (op-numeric-p op)))) |
357 | (if (functionp how) |
358 | (funcall how num) |
359 | (ret (if negp :negated-numeric :numeric) num))))) |
360 | ;; |
361 | ;; Long option. Find the matching option-spec and process |
362 | ;; it. |
363 | ((and (char= (char arg 0) #\-) |
364 | (char= (char arg 1) #\-)) |
365 | (eat-arg) |
366 | (process-long-option arg 2 nil)) |
367 | ;; |
368 | ;; Short options. All that's left. |
369 | (t |
370 | (eat-arg) |
371 | (let ((negp (char= (char arg 0) #\+)) |
372 | (ch (char arg 1))) |
373 | (cond ((and (op-long-only-p op) |
374 | (not (member ch (op-options op) |
375 | :key #'opt-short-name))) |
376 | (process-long-option arg 1 negp)) |
377 | (t |
378 | (setf (op-short-opt op) arg |
379 | (op-short-opt-index op) 1 |
380 | (op-short-opt-neg-p op) negp))))))))))))) |
381 | |
382 | (defmacro option-parse-try (&body body) |
383 | "Report errors encountered while parsing options, and continue struggling |
384 | along. Also establishes a restart `stop-parsing'. Returns t if parsing |
385 | completed successfully, or nil if errors occurred." |
386 | (with-gensyms (retcode) |
387 | `(let ((,retcode t)) |
388 | (restart-case |
389 | (handler-bind |
390 | ((option-parse-error |
391 | (lambda (cond) |
392 | (setf ,retcode nil) |
393 | (moan "~A" cond) |
394 | (dolist (rn '(skip-option stop-parsing)) |
395 | (let ((r (find-restart rn))) |
396 | (when r (invoke-restart r))))))) |
397 | ,@body) |
398 | (stop-parsing () |
399 | :report "Give up parsing options." |
400 | (setf ,retcode nil))) |
401 | ,retcode))) |
402 | |
403 | (defmacro with-unix-error-reporting ((&key) &body body) |
404 | "Evaluate BODY with errors reported in the standard Unix fashion." |
405 | (with-gensyms (cond) |
406 | `(handler-case |
407 | (progn ,@body) |
408 | (simple-condition (,cond) |
409 | (die (simple-condition-format-control ,cond) |
410 | (simple-condition-format-arguments ,cond))) |
411 | (error (,cond) |
412 | (die "~A" ,cond))))) |
413 | |
414 | ;;; Standard option handlers. |
415 | |
416 | (defmacro defopthandler (name (var &optional (arg (gensym))) |
417 | (&rest args) |
418 | &body body) |
419 | "Define an option handler function NAME. Option handlers update a |
420 | generalized variable, which may be referred to as VAR in the BODY, based on |
421 | some parameters (the ARGS) and the value of an option-argument named ARG." |
422 | (let ((func (intern (format nil "OPTHANDLER/~:@(~A~)" name)))) |
423 | `(progn |
424 | (setf (get ',name 'opthandler) ',func) |
425 | (defun ,func (,var ,arg ,@args) |
426 | (with-locatives ,var |
427 | (declare (ignorable ,arg)) |
428 | ,@body)) |
429 | ',name))) |
430 | |
431 | (defun parse-c-integer (string &key radix (start 0) end) |
432 | "Parse STRING, or at least the parts of it between START and END, according |
433 | to the standard C rules. Well, almost: the 0 and 0x prefixes are accepted, |
434 | but so too are 0o (Haskell) and 0b (original); also RADIX_DIGITS is accepted, |
435 | for any radix between 2 and 36. Prefixes are only accepted if RADIX is nil. |
436 | Returns two values: the integer parsed (or nil if there wasn't enough for a |
437 | sensible parse), and the index following the characters of the integer." |
438 | (unless end (setf end (length string))) |
439 | (labels ((simple (a i r goodp sgn) |
440 | (loop |
441 | (when (>= i end) |
442 | (return (values (and goodp (* a sgn)) i))) |
443 | (let ((d (digit-char-p (char string i) r))) |
444 | (unless d |
445 | (return (values (and goodp (* a sgn)) i))) |
446 | (setf a (+ (* a r) d)) |
447 | (setf goodp t) |
448 | (incf i)))) |
449 | (get-radix (i r sgn) |
450 | (cond (r (simple 0 i r nil sgn)) |
451 | ((>= i end) (values nil i)) |
452 | ((and (char= (char string i) #\0) |
453 | (>= (- end i) 2)) |
454 | (case (char string (1+ i)) |
455 | (#\x (simple 0 (+ i 2) 16 nil sgn)) |
456 | (#\o (simple 0 (+ i 2) 8 nil sgn)) |
457 | (#\b (simple 0 (+ i 2) 2 nil sgn)) |
458 | (t (simple 0 (1+ i) 8 t sgn)))) |
459 | (t |
460 | (multiple-value-bind |
461 | (r i) |
462 | (simple 0 i 10 nil +1) |
463 | (cond ((not r) (values nil i)) |
464 | ((and (< i end) |
465 | (char= (char string i) #\_) |
466 | (<= 2 r 36)) |
467 | (simple 0 (1+ i) r nil sgn)) |
468 | (t |
469 | (values (* r sgn) i)))))))) |
470 | (cond ((>= start end) (values nil start)) |
471 | ((char= (char string start) #\-) |
472 | (get-radix (1+ start) radix -1)) |
473 | ((char= (char string start) #\+) |
474 | (get-radix (1+ start) radix +1)) |
475 | (t |
476 | (get-radix start radix +1))))) |
477 | |
478 | (defun invoke-option-handler (handler loc arg args) |
479 | "Call the HANDLER function, giving it LOC to update, the option-argument |
480 | ARG, and the remaining ARGS." |
481 | (apply (if (functionp handler) handler |
482 | (fdefinition (get handler 'opthandler))) |
483 | loc |
484 | arg |
485 | args)) |
486 | |
487 | (defopthandler set (var) (&optional (value t)) |
488 | "Sets VAR to VALUE; defaults to t." |
489 | (setf var value)) |
490 | (defopthandler clear (var) (&optional (value nil)) |
491 | "Sets VAR to VALUE; defaults to nil." |
492 | (setf var value)) |
493 | (defopthandler inc (var) (&optional max (step 1)) |
494 | "Increments VAR by STEP (defaults to 1), but not greater than MAX (default |
495 | nil for no maximum). No errors are signalled." |
496 | (incf var step) |
497 | (when (>= var max) |
498 | (setf var max))) |
499 | (defopthandler dec (var) (&optional min (step 1)) |
500 | "Decrements VAR by STEP (defaults to 1), but not less than MIN (default nil |
501 | for no maximum). No errors are signalled." |
502 | (decf var step) |
503 | (when (<= var min) |
504 | (setf var min))) |
505 | (defopthandler read (var arg) () |
506 | "Stores in VAR the Lisp object found by reading the ARG. Evaluation is |
507 | forbidden while reading ARG. If there is an error during reading, an error |
508 | of type option-parse-error is signalled." |
509 | (handler-case |
510 | (let ((*read-eval* nil)) |
511 | (multiple-value-bind (x end) (read-from-string arg t) |
512 | (unless (>= end (length arg)) |
513 | (option-parse-error "Junk at end of argument `~A'" arg)) |
514 | (setf var x))) |
515 | (error (cond) |
516 | (option-parse-error (format nil "~A" cond))))) |
517 | (defopthandler int (var arg) (&key radix min max) |
518 | "Stores in VAR the integer read from the ARG. Integers are parsed |
519 | according to C rules, which is normal in Unix; the RADIX may be nil to allow |
520 | radix prefixes, or an integer between 2 and 36. An option-parse-error is |
521 | signalled if the ARG is not a valid integer, or if it is not between MIN and |
522 | MAX (either of which may be nil if no lower resp. upper bound is wanted)." |
523 | (multiple-value-bind (v end) (parse-c-integer arg :radix radix) |
524 | (unless (and v (>= end (length arg))) |
525 | (option-parse-error "Bad integer `~A'" arg)) |
526 | (when (or (and min (< v min)) |
527 | (and max (> v max))) |
528 | (option-parse-error |
529 | "Integer ~A out of range (must have ~@[~D <= ~]x~@[ <= ~D~])" |
530 | arg min max)) |
531 | (setf var v))) |
532 | (defopthandler string (var arg) () |
533 | "Stores ARG in VAR, just as it is." |
534 | (setf var arg)) |
535 | (defopthandler keyword (var arg) (&rest valid) |
536 | (if (null valid) |
537 | (setf var (intern (string-upcase arg) :keyword)) |
538 | (let ((matches nil) |
539 | (guess (string-upcase arg)) |
540 | (len (length arg))) |
541 | (dolist (k valid) |
542 | (let* ((kn (symbol-name k)) |
543 | (klen (length kn))) |
544 | (cond ((string= kn guess) |
545 | (setf matches (list k)) |
546 | (return)) |
547 | ((and (< len klen) |
548 | (string= guess kn :end2 len)) |
549 | (push k matches))))) |
550 | (case (length matches) |
551 | (0 (option-parse-error "Argument `~A' invalid: must be one of:~ |
552 | ~{~%~8T~(~A~)~}" |
553 | arg valid)) |
554 | (1 (setf var (car matches))) |
555 | (t (option-parse-error "Argument `~A' ambiguous: may be any of:~ |
556 | ~{~%~8T~(~A~)~}" |
557 | arg matches)))))) |
558 | (defopthandler list (var arg) (&optional handler &rest handler-args) |
559 | "Collect ARGs in a list at VAR. ARGs are translated by the HANDLER first, |
560 | if specified. If not, it's as if you asked for `string'." |
561 | (when handler |
562 | (invoke-option-handler handler (locf arg) arg handler-args)) |
563 | (setf var (nconc var (list arg)))) |
564 | |
565 | (compile-time-defun parse-option-form (form) |
566 | "Does the heavy lifting for parsing an option form. See the docstring for |
567 | the `option' macro for details of the syntax." |
568 | (flet ((doc (form) |
569 | (cond ((stringp form) form) |
570 | ((null (cdr form)) (car form)) |
571 | (t `(format nil ,@form)))) |
572 | (docp (form) |
573 | (or (stringp form) |
574 | (and (consp form) |
575 | (stringp (car form)))))) |
576 | (if (and (docp (car form)) |
577 | (null (cdr form))) |
578 | `(%make-option :documentation ,(doc (car form))) |
579 | (let (long-name short-name |
580 | arg-name arg-optional-p |
581 | tag negated-tag |
582 | doc) |
583 | (dolist (f form) |
584 | (cond ((and (or (not tag) (not negated-tag)) |
585 | (or (keywordp f) |
586 | (and (consp f) |
587 | (member (car f) '(lambda function))))) |
588 | (if tag |
589 | (setf negated-tag f) |
590 | (setf tag f))) |
591 | ((and (not long-name) |
592 | (or (rationalp f) |
593 | (symbolp f) |
594 | (stringp f))) |
595 | (setf long-name (if (stringp f) f |
596 | (format nil "~(~A~)" f)))) |
597 | ((and (not short-name) |
598 | (characterp f)) |
599 | (setf short-name f)) |
600 | ((and (not doc) |
601 | (docp f)) |
602 | (setf doc (doc f))) |
603 | ((and (consp f) (symbolp (car f))) |
604 | (case (car f) |
605 | (:arg (setf arg-name (cadr f))) |
606 | (:opt-arg (setf arg-name (cadr f)) |
607 | (setf arg-optional-p t)) |
608 | (:doc (setf doc (doc (cdr f)))) |
609 | (t (let ((handler (get (car f) 'opthandler))) |
610 | (unless handler |
611 | (error "No handler `~S' defined." (car f))) |
612 | (let* ((var (cadr f)) |
613 | (arg (gensym)) |
614 | (thunk `#'(lambda (,arg) |
615 | (,handler (locf ,var) |
616 | ,arg |
617 | ,@(cddr f))))) |
618 | (if tag |
619 | (setf negated-tag thunk) |
620 | (setf tag thunk))))))) |
621 | (t |
622 | (error "Unexpected thing ~S in option form." f)))) |
623 | `(make-option ,long-name ,short-name ,arg-name |
624 | ,@(and arg-optional-p `(:arg-optional-p t)) |
625 | ,@(and tag `(:tag ,tag)) |
626 | ,@(and negated-tag `(:negated-tag ,negated-tag)) |
627 | ,@(and doc `(:documentation ,doc))))))) |
628 | |
629 | (defmacro options (&rest optlist) |
630 | "More convenient way of initializing options. The OPTLIST is a list of |
631 | OPTFORMS. Each OPTFORM is either a banner string, or a list of |
632 | items. Acceptable items are interpreted as follows: |
633 | |
634 | KEYWORD or FUNCTION |
635 | If no TAG is set yet, then as a TAG; otherwise as the NEGATED-TAG. |
636 | |
637 | STRING (or SYMBOL or RATIONAL) |
638 | If no LONG-NAME seen yet, then the LONG-NAME. For symbols and rationals, |
639 | the item is converted to a string and squashed to lower-case. |
640 | |
641 | CHARACTER |
642 | The SHORT-NAME. |
643 | |
644 | STRING or (STRING STUFF...) |
645 | If no DOCUMENTATION set yet, then the DOCUMENTATION string. A string is |
646 | used as-is; a list is considered to be a `format' string and its |
647 | arguments. This is evaluated at standard evaluation time: the option |
648 | structure returned contains a simple documentation string. |
649 | |
650 | (:ARG NAME) |
651 | Set the ARG-NAME. |
652 | |
653 | (:OPT-ARG NAME) |
654 | Set the ARG-NAME, and also set ARG-OPTIONAL-P. |
655 | |
656 | (HANDLER VAR ARGS...) |
657 | If no TAG is set yet, attach the HANDLER to this option, giving it ARGS. |
658 | Otherwise, set the NEGATED-TAG." |
659 | `(list ,@(mapcar (lambda (form) |
660 | (if (stringp form) |
661 | `(%make-option :documentation ,form) |
662 | (parse-option-form form))) |
663 | optlist))) |
664 | |
665 | ;;; Support stuff for help and usage messages |
666 | |
667 | (defun print-text (string |
668 | &optional |
669 | (stream *standard-output*) |
670 | &key |
671 | (start 0) |
672 | (end nil)) |
673 | "Prints STRING to a pretty-printed STREAM, breaking it at whitespace and |
674 | newlines in the obvious way. Stuff between square brackets is not broken: |
675 | this makes usage messages work better." |
676 | (let ((i start) |
677 | (nest 0) |
678 | (splitp nil)) |
679 | (flet ((emit () |
680 | (write-string string stream :start start :end i) |
681 | (setf start i))) |
682 | (unless end |
683 | (setf end (length string))) |
684 | (loop |
685 | (unless (< i end) |
686 | (emit) |
687 | (return)) |
688 | (let ((ch (char string i))) |
689 | (cond ((char= ch #\newline) |
690 | (emit) |
691 | (incf start) |
692 | (pprint-newline :mandatory stream)) |
693 | ((whitespace-char-p ch) |
694 | (when (zerop nest) |
695 | (setf splitp t))) |
696 | (t |
697 | (when splitp |
698 | (emit) |
699 | (pprint-newline :fill stream)) |
700 | (setf splitp nil) |
701 | (case ch |
702 | (#\[ (incf nest)) |
703 | (#\] (when (plusp nest) (decf nest)))))) |
704 | (incf i)))))) |
705 | |
706 | (defun simple-usage (opts &optional mandatory-args) |
707 | "Build a simple usage list from a list of options, and (optionally) |
708 | mandatory argument names." |
709 | (let (short-simple long-simple short-arg long-arg) |
710 | (dolist (o opts) |
711 | (cond ((not (and (opt-documentation o) |
712 | (opt-long-name o)))) |
713 | ((and (opt-short-name o) (opt-arg-name o)) |
714 | (push o short-arg)) |
715 | ((opt-short-name o) |
716 | (push o short-simple)) |
717 | ((opt-arg-name o) |
718 | (push o long-arg)) |
719 | (t |
720 | (push o long-simple)))) |
721 | (list |
722 | (nconc (and short-simple |
723 | (list (format nil "[-~{~C~}]" |
724 | (sort (mapcar #'opt-short-name short-simple) |
725 | #'char<)))) |
726 | (and long-simple |
727 | (mapcar (lambda (o) |
728 | (format nil "[--~A]" (opt-long-name o))) |
729 | (sort long-simple #'string< :key #'opt-long-name))) |
730 | (and short-arg |
731 | (mapcar (lambda (o) |
732 | (format nil "~:[[-~C ~A]~;[-~C[~A]]~]" |
733 | (opt-arg-optional-p o) |
734 | (opt-short-name o) |
735 | (opt-arg-name o))) |
736 | (sort short-arg #'char-lessp |
737 | :key #'opt-short-name))) |
738 | (and long-arg |
739 | (mapcar (lambda (o) |
740 | (format nil "~:[[--~A ~A]~;[--~A[=~A]]~]" |
741 | (opt-arg-optional-p o) |
742 | (opt-long-name o) |
743 | (opt-arg-name o))) |
744 | (sort long-arg #'string-lessp |
745 | :key #'opt-long-name))) |
746 | (listify mandatory-args))))) |
747 | |
748 | (defun show-usage (prog usage &optional (stream *standard-output*)) |
749 | "Basic usage-showing function. PROG is the program name, probable from |
750 | *command-line-strings*. USAGE is a list of possible usages of the program, |
751 | each of which is a list of items to be supplied by the user. In simple |
752 | cases, a single string is sufficient." |
753 | (pprint-logical-block (stream nil :prefix "Usage: ") |
754 | (dolist (u (listify usage)) |
755 | (pprint-logical-block (stream nil :prefix (format nil "~A " prog)) |
756 | (format stream "~{~A ~:_~}" (listify u))) |
757 | (pprint-newline :mandatory stream)))) |
758 | |
759 | (defun show-help (prog ver usage opts &optional (stream *standard-output*)) |
760 | "Basic help-showing function. PROG is the program name, probably from |
761 | *command-line-strings*. VER is the program's version number. USAGE is a |
762 | list of the possible usages of the program, each of which may be a list of |
763 | items to be supplied. OPTS is the list of supported options, as provided to |
764 | the options parser. STREAM is the stream to write on." |
765 | (format stream "~A, version ~A~2%" prog ver) |
766 | (show-usage prog usage stream) |
767 | (terpri stream) |
768 | (let (newlinep) |
769 | (dolist (o opts) |
770 | (let ((doc (opt-documentation o))) |
771 | (cond ((not o)) |
772 | ((not (opt-long-name o)) |
773 | (when newlinep |
774 | (terpri stream) |
775 | (setf newlinep nil)) |
776 | (pprint-logical-block (stream nil) |
777 | (print-text doc stream)) |
778 | (terpri stream)) |
779 | (t |
780 | (setf newlinep t) |
781 | (pprint-logical-block (stream nil :prefix " ") |
782 | (pprint-indent :block 30 stream) |
783 | (format stream "~:[ ~;-~:*~C,~] --~A" |
784 | (opt-short-name o) |
785 | (opt-long-name o)) |
786 | (when (opt-arg-name o) |
787 | (format stream "~:[=~A~;[=~A]~]" |
788 | (opt-arg-optional-p o) |
789 | (opt-arg-name o))) |
790 | (write-string " " stream) |
791 | (pprint-tab :line 30 1 stream) |
792 | (print-text doc stream)) |
793 | (terpri stream))))))) |
794 | |
795 | (defun sanity-check-option-list (opts) |
796 | "Check the option list OPTS for basic sanity. Reused short and long option |
797 | names are diagnosed. Maybe other problems will be reported later. Returns a |
798 | list of warning strings." |
799 | (let ((problems nil) |
800 | (longs (make-hash-table :test #'equal)) |
801 | (shorts (make-hash-table))) |
802 | (flet ((problem (msg &rest args) |
803 | (push (apply #'format nil msg args) problems))) |
804 | (dolist (o opts) |
805 | (push o (gethash (opt-long-name o) longs)) |
806 | (push o (gethash (opt-short-name o) shorts))) |
807 | (maphash (lambda (k v) |
808 | (when (and k (cdr v)) |
809 | (problem "Long name `--~A' reused in ~S" k v))) |
810 | longs) |
811 | (maphash (lambda (k v) |
812 | (when (and k (cdr v)) |
813 | (problem "Short name `-~C' reused in ~S" k v))) |
814 | shorts) |
815 | problems))) |
816 | |
817 | ;;;----- That's all, folks -------------------------------------------------- |