3 ;;; Option parser, standard issue
5 ;;; (c) 2005 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
10 ;;; This program is free software; you can redistribute it and/or modify
11 ;;; it under the terms of the GNU General Public License as published by
12 ;;; the Free Software Foundation; either version 2 of the License, or
13 ;;; (at your option) any later version.
15 ;;; This program is distributed in the hope that it will be useful,
16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;;; GNU General Public License for more details.
20 ;;; You should have received a copy of the GNU General Public License
21 ;;; along with this program; if not, write to the Free Software Foundation,
22 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
24 ;;;--------------------------------------------------------------------------
27 (defpackage #:optparse
28 (:use #:common-lisp #:mdw.base #:mdw.sys-base))
30 (in-package #:optparse)
32 ;; Re-export symbols from sys-base.
33 (export '(exit *program-name* *command-line*))
35 ;;;--------------------------------------------------------------------------
36 ;;; Standard error-reporting functions.
39 (defun moan (msg &rest args)
40 "Report an error message in the usual way."
41 (format *error-output* "~&~A: ~?~%" *program-name* msg args))
44 (defun die (&rest args)
45 "Report an error message and exit."
49 ;;;--------------------------------------------------------------------------
50 ;;; The main option parser.
53 (defvar *options* nil)
55 (export '(option optionp make-option
56 opt-short-name opt-long-name opt-tag opt-negated-tag
57 opt-arg-name opt-arg-optional-p opt-documentation))
64 (print-unreadable-object (o s :type t)
65 (format s "~@[-~C, ~]~@[--~A~]~
66 ~*~@[~2:*~:[=~A~;[=~A]~]~]~
70 (opt-arg-optional-p o)
72 (opt-documentation o)))))
73 (:constructor %make-option)
74 (:constructor make-option
77 &key (tag (intern (string-upcase long-name) :keyword))
80 doc (documentation doc))))
81 "Describes a command-line option. Slots:
83 LONG-NAME The option's long name. If this is null, the `option' is
84 just a banner to be printed in the program's help text.
86 TAG The value to be returned if this option is encountered. If
87 this is a function, instead, the function is called with the
88 option's argument or nil.
90 NEGATED-TAG As for TAG, but used if the negated form of the option is
91 found. If this is nil (the default), the option cannot be
94 SHORT-NAME The option's short name. This must be a single character, or
95 nil if the option has no short name.
97 ARG-NAME The name of the option's argument, a string. If this is nil,
98 the option doesn't accept an argument. The name is shown in
102 If non-nil, the option's argument is optional. This is
103 ignored unless ARG-NAME is non-null.
106 The help text for this option. It is automatically line-
107 wrapped. If nil, the option is omitted from the help
110 Usually, one won't use make-option, but use the option macro instead."
111 (long-name nil :type (or null string) :read-only t)
112 (tag nil :type t :read-only t)
113 (negated-tag nil :type t :read-only t)
114 (short-name nil :type (or null character) :read-only t)
115 (arg-name nil :type (or null string) :read-only t)
116 (arg-optional-p nil :type t :read-only t)
117 (documentation nil :type (or null string)) :read-only t)
119 (export '(option-parser option-parser-p make-option-parser
120 op-options op-non-option op-long-only-p
121 op-numeric-p op-negated-numeric-p op-negated-p))
122 (defstruct (option-parser
124 (:constructor make-option-parser
125 (&key ((:args argstmp) (cdr *command-line*))
128 ((:numericp numeric-p))
131 &aux (args (cons nil argstmp))
133 (negated-p (or negated-numeric-p
134 (some #'opt-negated-tag
136 "An option parser object. Slots:
138 ARGS The arguments to be parsed. Usually this will be
141 OPTIONS List of option structures describing the acceptable options.
143 NON-OPTION Behaviour when encountering a non-option argument. The
144 default is :skip. Allowable values are:
145 :skip -- pretend that it appeared after the option
146 arguments; this is the default behaviour of GNU getopt
147 :stop -- stop parsing options, leaving the remaining
148 command line unparsed
149 :return -- return :non-option and the argument word
151 NUMERIC-P Non-nil tag (as for options) if numeric options (e.g., -43)
152 are to be allowed. The default is nil. (Anomaly: the
153 keyword for this argument is :numericp.)
156 Non-nil tag (as for options) if numeric options (e.g., -43)
157 can be negated. This is not the same thing as a negative
160 LONG-ONLY-P A misnomer inherited from GNU getopt. Whether to allow
161 long options to begin with a single dash. Short options are
162 still allowed, and may be cuddled as usual. The default is
164 (args nil :type list)
165 (options nil :type list :read-only t)
166 (non-option :skip :type (or function (member :skip :stop :return))
168 (next nil :type list)
169 (short-opt nil :type (or null string))
170 (short-opt-index 0 :type fixnum)
171 (short-opt-neg-p nil :type t)
172 (long-only-p nil :type t :read-only t)
173 (numeric-p nil :type t :read-only t)
174 (negated-numeric-p nil :type t :read-only t)
175 (negated-p nil :type t) :read-only t)
177 (export 'option-parse-error)
178 (define-condition option-parse-error (error simple-condition)
181 "Indicates an error found while parsing options. Probably not that
184 (defun option-parse-error (msg &rest args)
185 "Signal an option-parse-error with the given message and arguments."
186 (error (make-condition 'option-parse-error
188 :format-arguments args)))
190 (export 'option-parse-remainder)
191 (defun option-parse-remainder (op)
192 "Returns the unparsed remainder of the command line."
195 (export 'option-parse-return)
196 (defun option-parse-return (tag &optional argument)
197 "Should be called from an option handler: forces a return from the
198 immediately enclosing `option-parse-next' with the given TAG and
200 (throw 'option-parse-return (values tag argument)))
202 (export 'option-parse-next)
203 (defun option-parse-next (op)
204 "The main option-parsing function. OP is an option-parser object,
205 initialized appropriately. Returns two values, OPT and ARG: OPT is the
206 tag of the next option read, and ARG is the argument attached to it, or
207 nil if there was no argument. If there are no more options, returns nil
208 twice. Options whose TAG is a function aren't returned; instead, the tag
209 function is called, with the option argument (or nil) as the only
210 argument. It is safe for tag functions to throw out of option-parse-next,
211 if they desparately need to. (This is the only way to actually get
212 option-parse-next to return a function value, should that be what you
213 want. See `option-parse-return' for a way of doing this.)
215 While option-parse-next is running, there is a restart `skip-option' which
216 moves on to the next option. Error handlers should use this to resume
217 after parsing errors."
218 (labels ((ret (opt &optional arg)
219 (return-from option-parse-next (values opt arg)))
221 (setf (op-next op) nil)
229 (setf (op-next op) (cdr (op-next op))))
231 (setf (cdr (op-next op)) (cddr (op-next op))))
233 (prog1 (peek-arg) (eat-arg)))
234 (process-option (o name negp &key arg argfunc)
235 (cond ((not (opt-arg-name o))
238 "Option `~A' does not accept arguments"
242 (setf arg (funcall argfunc)))
243 ((opt-arg-optional-p o))
245 (setf arg (get-arg)))
247 (option-parse-error "Option `~A' requires an argument"
249 (let ((how (if negp (opt-negated-tag o) (opt-tag o))))
253 (process-long-option (arg start negp)
254 (when (and (not negp)
256 (> (length arg) (+ start 3))
258 :start1 start :end1 (+ start 3)))
262 (eqpos (position #\= arg :start start))
263 (len (or eqpos (length arg)))
264 (optname (subseq arg 0 len))
265 (len-2 (- len start)))
266 (dolist (o (op-options op))
267 (cond ((or (not (stringp (opt-long-name o)))
268 (and negp (not (opt-negated-tag o)))
269 (< (length (opt-long-name o)) len-2)
270 (string/= optname (opt-long-name o)
271 :start1 start :end2 len-2)))
272 ((= (length (opt-long-name o)) len-2)
273 (setf matches (list o))
277 (cond ((null matches)
278 (option-parse-error "Unknown option `~A'" optname))
281 #.(concatenate 'string
282 "Ambiguous long option `~A' -- "
286 (mapcar #'opt-long-name matches))))
287 (process-option (car matches)
291 (subseq arg (1+ eqpos)))))))
292 (catch 'option-parse-return
294 (with-simple-restart (skip-option "Skip this bogus option.")
297 ;; We're embroiled in short options: handle them.
299 (if (>= (op-short-opt-index op) (length (op-short-opt op)))
300 (setf (op-short-opt op) nil)
301 (let* ((str (op-short-opt op))
302 (i (op-short-opt-index op))
304 (negp (op-short-opt-neg-p op))
305 (name (format nil "~C~A" (if negp #\+ #\-) ch))
306 (o (find ch (op-options op) :key #'opt-short-name)))
308 (setf (op-short-opt-index op) i)
310 (and negp (not (opt-negated-tag o))))
311 (option-parse-error "Unknown option `~A'" name))
316 (and (< i (length str))
320 (setf (op-short-opt op)
323 ;; End of the list. Say we've finished.
327 ;; Process the next option.
329 (let ((arg (peek-arg)))
332 ;; Non-option. Decide what to do.
333 ((or (<= (length arg) 1)
334 (and (char/= (char arg 0) #\-)
335 (or (char/= (char arg 0) #\+)
336 (not (op-negated-p op)))))
337 (case (op-non-option op)
341 (ret :non-option arg))
343 (funcall (op-non-option op) arg))))
345 ;; Double-hyphen. Stop right now.
350 ;; Numbers. Check these before long options, since `--43'
351 ;; is not a long option.
352 ((and (op-numeric-p op)
353 (or (char= (char arg 0) #\-)
354 (op-negated-numeric-p op))
355 (or (and (digit-char-p (char arg 1))
356 (every #'digit-char-p (subseq arg 2)))
357 (and (or (char= (char arg 1) #\-)
358 (char= (char arg 1) #\+))
360 (digit-char-p (char arg 2))
361 (every #'digit-char-p (subseq arg 3)))))
363 (let ((negp (char= (char arg 0) #\+))
364 (num (parse-integer arg :start 1)))
365 (when (and negp (eq (op-negated-numeric-p op) :-))
369 (op-negated-numeric-p op)
373 (ret (if negp :negated-numeric :numeric) num)))))
375 ;; Long option. Find the matching option-spec and process
377 ((and (char= (char arg 0) #\-)
378 (char= (char arg 1) #\-))
380 (process-long-option arg 2 nil))
382 ;; Short options. All that's left.
385 (let ((negp (char= (char arg 0) #\+))
387 (cond ((and (op-long-only-p op)
388 (not (member ch (op-options op)
389 :key #'opt-short-name)))
390 (process-long-option arg 1 negp))
392 (setf (op-short-opt op) arg
393 (op-short-opt-index op) 1
394 (op-short-opt-neg-p op) negp))))))))))))))
396 (export 'option-parse-try)
397 (defmacro option-parse-try (&body body)
398 "Report errors encountered while parsing options, and continue struggling
399 along. Also establishes a restart `stop-parsing'. Returns t if parsing
400 completed successfully, or nil if errors occurred."
401 (with-gensyms (retcode)
409 (dolist (rn '(skip-option stop-parsing))
410 (let ((r (find-restart rn)))
411 (when r (invoke-restart r)))))))
414 :report "Give up parsing options."
415 (setf ,retcode nil)))
418 (export 'with-unix-error-reporting)
419 (defmacro with-unix-error-reporting ((&key) &body body)
420 "Evaluate BODY with errors reported in the standard Unix fashion."
424 (simple-condition (,cond)
426 (simple-condition-format-control ,cond)
427 (simple-condition-format-arguments ,cond)))
431 ;;;--------------------------------------------------------------------------
432 ;;; Standard option handlers.
434 (export 'defopthandler)
435 (defmacro defopthandler (name (var &optional (arg (gensym)))
438 "Define an option handler function NAME. Option handlers update a
439 generalized variable, which may be referred to as VAR in the BODY, based
440 on some parameters (the ARGS) and the value of an option-argument named
442 (let ((func (intern (format nil "OPTHANDLER/~:@(~A~)" name))))
443 (with-parsed-body (body decls docs) body
445 (setf (get ',name 'opthandler) ',func)
446 (defun ,func (,var ,arg ,@args)
448 (declare (ignorable ,arg))
453 (defun parse-c-integer (string &key radix (start 0) end)
454 "Parse STRING, or at least the parts of it between START and END, according
455 to the standard C rules. Well, almost: the 0 and 0x prefixes are
456 accepted, but so too are 0o (Haskell) and 0b (original); also RADIX_DIGITS
457 is accepted, for any radix between 2 and 36. Prefixes are only accepted
458 if RADIX is nil. Returns two values: the integer parsed (or nil if there
459 wasn't enough for a sensible parse), and the index following the
460 characters of the integer."
461 (setf-default end (length string))
462 (labels ((simple (i r goodp sgn)
466 (digit-char-p (char string i) r))
467 (parse-integer string
472 (values (if a (* sgn a) (and goodp 0)) i)))
474 (cond (r (simple i r nil sgn))
475 ((>= i end) (values nil i))
476 ((and (char= (char string i) #\0)
478 (case (char string (1+ i))
479 (#\x (simple (+ i 2) 16 nil sgn))
480 (#\o (simple (+ i 2) 8 nil sgn))
481 (#\b (simple (+ i 2) 2 nil sgn))
482 (t (simple (1+ i) 8 t sgn))))
487 (cond ((not r) (values nil i))
489 (char= (char string i) #\_)
491 (simple (1+ i) r nil sgn))
493 (values (* r sgn) i))))))))
494 (cond ((>= start end) (values nil start))
495 ((char= (char string start) #\-)
496 (get-radix (1+ start) radix -1))
497 ((char= (char string start) #\+)
498 (get-radix (1+ start) radix +1))
500 (get-radix start radix +1)))))
502 (export 'invoke-option-handler)
503 (defun invoke-option-handler (handler loc arg args)
504 "Call the HANDLER function, giving it LOC to update, the option-argument
505 ARG, and the remaining ARGS."
506 (apply (if (functionp handler) handler
507 (fdefinition (get handler 'opthandler)))
512 ;;;--------------------------------------------------------------------------
513 ;;; Built-in option handlers.
516 (defopthandler set (var) (&optional (value t))
517 "Sets VAR to VALUE; defaults to t."
521 (defopthandler clear (var) (&optional (value nil))
522 "Sets VAR to VALUE; defaults to nil."
526 (defopthandler inc (var) (&optional max (step 1))
527 "Increments VAR by STEP (defaults to 1), but not greater than MAX (default
528 nil for no maximum). No errors are signalled."
534 (defopthandler dec (var) (&optional min (step 1))
535 "Decrements VAR by STEP (defaults to 1), but not less than MIN (default nil
536 for no maximum). No errors are signalled."
542 (defopthandler read (var arg) ()
543 "Stores in VAR the Lisp object found by reading the ARG. Evaluation is
544 forbidden while reading ARG. If there is an error during reading, an
545 error of type option-parse-error is signalled."
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))
553 (option-parse-error (format nil "~A" cond)))))
556 (defopthandler int (var arg) (&key radix min max)
557 "Stores in VAR the integer read from the ARG. Integers are parsed
558 according to C rules, which is normal in Unix; the RADIX may be nil to
559 allow radix prefixes, or an integer between 2 and 36. An
560 option-parse-error is signalled if the ARG is not a valid integer, or if
561 it is not between MIN and MAX (either of which may be nil if no lower
562 resp. upper bound is wanted)."
563 (multiple-value-bind (v end) (parse-c-integer arg :radix radix)
564 (unless (and v (>= end (length arg)))
565 (option-parse-error "Bad integer `~A'" arg))
566 (when (or (and min (< v min))
569 #.(concatenate 'string
570 "Integer ~A out of range "
571 "(must have ~@[~D <= ~]x~@[ <= ~D~])")
576 (defopthandler string (var arg) ()
577 "Stores ARG in VAR, just as it is."
581 (defopthandler keyword (var arg) (&optional (valid t))
582 "Converts ARG into a keyword. If VALID is t, then any ARG string is
583 acceptable: the argument is uppercased and interned in the keyword
584 package. If VALID is a list, then we ensure that ARG matches one of the
585 elements of the list; unambigious abbreviations are allowed."
588 (setf var (intern (string-upcase arg) :keyword)))
591 (guess (string-upcase arg))
594 (let* ((kn (symbol-name k))
596 (cond ((string= kn guess)
597 (setf matches (list k))
600 (string= guess kn :end2 len))
604 (option-parse-error #.(concatenate 'string
605 "Argument `~A' invalid: "
609 ((null (cdr matches))
610 (setf var (car matches)))
612 (option-parse-error #.(concatenate 'string
613 "Argument `~A' ambiguous: "
619 (defopthandler list (var arg) (&optional handler &rest handler-args)
620 "Collect ARGs in a list at VAR. ARGs are translated by the HANDLER first,
621 if specified. If not, it's as if you asked for `string'."
623 (invoke-option-handler handler (locf arg) arg handler-args))
624 (setf var (nconc var (list arg))))
626 ;;;--------------------------------------------------------------------------
627 ;;; Option descriptions.
629 (export 'defoptmacro)
630 (defmacro defoptmacro (name args &body body)
631 "Defines an option macro NAME. Option macros should produce a list of
632 expressions producing one option structure each."
634 (setf (get ',name 'optmacro) (lambda ,args ,@body))
637 (export 'parse-option-form)
638 (compile-time-defun parse-option-form (form)
639 "Does the heavy lifting for parsing an option form. See the docstring for
640 the `option' macro for details of the syntax."
642 (cond ((stringp form) form)
643 ((null (cdr form)) (car form))
644 (t `(format nil ,@form))))
648 (stringp (car form))))))
649 (cond ((stringp form)
650 `(%make-option :documentation ,form))
652 (error "option form must be string or list"))
653 ((and (docp (car form)) (null (cdr form)))
654 `(%make-option :documentation ,(doc (car form))))
656 (let (long-name short-name
657 arg-name arg-optional-p
661 (cond ((and (or (not tag) (not negated-tag))
664 (member (car f) '(lambda function)))))
668 ((and (not long-name)
672 (setf long-name (if (stringp f) f
673 (format nil "~(~A~)" f))))
674 ((and (not short-name)
680 ((and (consp f) (symbolp (car f)))
682 (:short-name (setf short-name (cadr f)))
683 (:long-name (setf long-name (cadr f)))
684 (:tag (setf tag (cadr f)))
685 (:negated-tag (setf negated-tag (cadr f)))
686 (:arg (setf arg-name (cadr f)))
687 (:opt-arg (setf arg-name (cadr f))
688 (setf arg-optional-p t))
689 (:doc (setf doc (doc (cdr f))))
690 (t (let ((handler (get (car f) 'opthandler)))
692 (error "No handler `~S' defined." (car f)))
693 (let* ((var (cadr f))
695 (thunk `#'(lambda (,arg)
696 (,handler (locf ,var)
700 (setf negated-tag thunk)
701 (setf tag thunk)))))))
703 (error "Unexpected thing ~S in option form." f))))
704 `(make-option ,long-name ,short-name ,arg-name
705 ,@(and arg-optional-p `(:arg-optional-p t))
706 ,@(and tag `(:tag ,tag))
707 ,@(and negated-tag `(:negated-tag ,negated-tag))
708 ,@(and doc `(:documentation ,doc))))))))
711 (defmacro options (&rest optlist)
712 "More convenient way of initializing options. The OPTLIST is a list of
713 OPTFORMS. Each OPTFORM is one of the following:
715 STRING A banner to print.
717 SYMBOL or (SYMBOL STUFF...)
718 If SYMBOL is an optform macro, the result of invoking it.
720 (...) A full option-form. See below.
722 Full option-forms are a list of the following kinds of items.
730 Set the appropriate slot of the option to the given value.
731 The argument is evaluated.
733 (:doc FORMAT-CONTROL ARGUMENTS...)
734 As for (:doc (format nil FORMAT-CONTROL ARGUMENTS...)).
736 KEYWORD, (function ...), (lambda ...)
737 If no TAG is set yet, then as a TAG; otherwise as the
740 STRING (or SYMBOL or RATIONAL)
741 If no LONG-NAME seen yet, then the LONG-NAME. For symbols
742 and rationals, the item is converted to a string and squashed
745 CHARACTER If no SHORT-NAME, then the SHORT-NAME.
747 STRING or (STRING STUFF...)
748 If no DOCUMENTATION set yet, then the DOCUMENTATION string,
749 as for (:doc STRING STUFF...)
752 Set the ARG-NAME, and also set ARG-OPTIONAL-P.
754 (HANDLER VAR ARGS...)
755 If no TAG is set yet, attach the HANDLER to this option,
756 giving it ARGS. Otherwise, set the NEGATED-TAG."
758 `(list ,@(mapcan (lambda (form)
761 (cond ((symbolp form) (values form nil))
762 ((and (consp form) (symbolp (car form)))
763 (values (car form) (cdr form)))
764 (t (values nil nil)))
765 (let ((macro (and sym (get sym 'optmacro))))
768 (list (parse-option-form form))))))
771 ;;;--------------------------------------------------------------------------
772 ;;; Support stuff for help and usage messages.
774 (defun print-text (string
776 (stream *standard-output*)
780 "Prints STRING to a pretty-printed STREAM, breaking it at whitespace and
781 newlines in the obvious way. Stuff between square brackets is not broken:
782 this makes usage messages work better."
787 (write-string string stream :start start :end i)
789 (setf-default end (length string))
794 (let ((ch (char string i)))
795 (cond ((char= ch #\newline)
798 (pprint-newline :mandatory stream))
799 ((whitespace-char-p ch)
805 (pprint-newline :fill stream))
809 (#\] (when (plusp nest) (decf nest))))))
812 (export 'simple-usage)
813 (defun simple-usage (opts &optional mandatory-args)
814 "Build a simple usage list from a list of options, and (optionally)
815 mandatory argument names."
816 (let (short-simple long-simple short-arg long-arg)
818 (cond ((not (and (opt-documentation o)
820 ((and (opt-short-name o) (opt-arg-name o))
823 (push o short-simple))
827 (push o long-simple))))
829 (nconc (and short-simple
830 (list (format nil "[-~{~C~}]"
831 (sort (mapcar #'opt-short-name short-simple)
835 (format nil "[--~A]" (opt-long-name o)))
836 (sort long-simple #'string< :key #'opt-long-name)))
839 (format nil "~:[[-~C ~A]~;[-~C[~A]]~]"
840 (opt-arg-optional-p o)
843 (sort short-arg #'char-lessp
844 :key #'opt-short-name)))
847 (format nil "~:[[--~A ~A]~;[--~A[=~A]]~]"
848 (opt-arg-optional-p o)
851 (sort long-arg #'string-lessp
852 :key #'opt-long-name)))
853 (listify mandatory-args)))))
856 (defun show-usage (prog usage &optional (stream *standard-output*))
857 "Basic usage-showing function. PROG is the program name, probably from
858 *command-line*. USAGE is a list of possible usages of the program, each
859 of which is a list of items to be supplied by the user. In simple cases,
860 a single string is sufficient."
861 (pprint-logical-block (stream nil :prefix "Usage: ")
862 (dolist (u (listify usage))
863 (pprint-logical-block (stream nil
864 :prefix (concatenate 'string prog " "))
865 (format stream "~{~A ~:_~}" (listify u)))
866 (pprint-newline :mandatory stream))))
868 (defun show-options-help (opts &optional (stream *standard-output*))
869 "Write help for OPTS to the STREAM. This is the core of the `show-help'
873 (let ((doc (opt-documentation o)))
875 ((not (opt-long-name o))
879 (pprint-logical-block (stream nil)
880 (print-text doc stream))
884 (pprint-logical-block (stream nil :prefix " ")
885 (format stream "~:[ ~;-~:*~C,~] --~A"
888 (when (opt-arg-name o)
889 (format stream "~:[=~A~;[=~A]~]"
890 (opt-arg-optional-p o)
892 (write-string " " stream)
893 (pprint-tab :line 30 1 stream)
894 (pprint-indent :block 30 stream)
895 (print-text doc stream))
896 (terpri stream)))))))
899 (defun show-help (prog ver usage opts &optional (stream *standard-output*))
900 "Basic help-showing function. PROG is the program name, probably from
901 *command-line*. VER is the program's version number. USAGE is a list of
902 the possible usages of the program, each of which may be a list of items
903 to be supplied. OPTS is the list of supported options, as provided to the
904 options parser. STREAM is the stream to write on."
905 (format stream "~A, version ~A~2%" prog ver)
906 (show-usage prog usage stream)
908 (show-options-help opts stream))
910 (export 'sanity-check-options-list)
911 (defun sanity-check-option-list (opts)
912 "Check the option list OPTS for basic sanity. Reused short and long option
913 names are diagnosed. Maybe other problems will be reported later.
914 Returns a list of warning strings."
916 (longs (make-hash-table :test #'equal))
917 (shorts (make-hash-table)))
918 (flet ((problem (msg &rest args)
919 (push (apply #'format nil msg args) problems)))
921 (push o (gethash (opt-long-name o) longs))
922 (push o (gethash (opt-short-name o) shorts)))
923 (maphash (lambda (k v)
924 (when (and k (cdr v))
925 (problem "Long name `--~A' reused in ~S" k v)))
927 (maphash (lambda (k v)
928 (when (and k (cdr v))
929 (problem "Short name `-~C' reused in ~S" k v)))
933 ;;;--------------------------------------------------------------------------
934 ;;; Full program descriptions.
936 (export '(*help* *version* *usage))
938 (defvar *version* "<unreleased>")
942 (defun do-usage (&optional (stream *standard-output*))
943 (show-usage *program-name* *usage* stream))
947 (do-usage *error-output*)
950 (defun opt-help (arg)
951 (declare (ignore arg))
952 (show-help *program-name* *version* *usage* *options*)
954 (string (terpri) (write-string *help*))
956 ((or function symbol) (terpri) (funcall *help*)))
959 (defun opt-version (arg)
960 (declare (ignore arg))
961 (format t "~A, version ~A~%" *program-name* *version*)
963 (defun opt-usage (arg)
964 (declare (ignore arg))
968 (export 'help-options)
969 (defoptmacro help-options (&key (short-help #\h)
972 "Inserts a standard help options collection in an options list."
973 (flet ((shortform (char)
974 (and char (list char))))
978 (,@(shortform short-help) "help" #'opt-help
979 "Show this help message.")
980 (,@(shortform short-version) "version" #'opt-version
981 ("Show ~A's version number." *program-name*))
982 (,@(shortform short-usage) "usage" #'opt-usage
983 ("Show a very brief usage summary for ~A." *program-name*))))))
985 (export 'define-program)
986 (defun define-program (&key
987 (program-name nil progp)
989 (version nil versionp)
991 (full-usage nil fullp)
993 "Sets up all the required things a program needs to have to parse options
994 and respond to them properly."
995 (when progp (setf *program-name* program-name))
996 (when helpp (setf *help* help))
997 (when versionp (setf *version* version))
998 (when optsp (setf *options* options))
999 (cond ((and usagep fullp) (error "conflicting options"))
1000 (usagep (setf *usage* (simple-usage *options* usage)))
1001 (fullp (setf *usage* full-usage))))
1003 (export 'do-options)
1004 (defmacro do-options ((&key (parser '(make-option-parser)))
1006 "Handy all-in-one options parser macro. PARSER defaults to a new options
1007 parser using the preset default options structure. The CLAUSES are
1008 `case2'-like clauses to match options, and must be exhaustive. If there
1009 is a clause (nil (REST) FORMS...) then the FORMS are evaluated after
1010 parsing is done with REST bound to the remaining command-line arguments."
1011 (let*/gensyms (parser)
1014 (,(if (find t clauses :key #'car) 'case2 'ecase2)
1015 (option-parse-next ,parser)
1017 ,@(remove-if #'null clauses :key #'car)))
1018 ,@(let ((tail (find nil clauses :key #'car)))
1020 (destructuring-bind ((&optional arg) &rest forms) (cdr tail)
1022 (list `(let ((,arg (option-parse-remainder ,parser)))
1026 ;;;----- That's all, folks --------------------------------------------------