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