3 ;;; Option parser, standard issue
5 ;;; (c) 2005 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
10 ;;; This file is part of the Sensble Object Design, an object system for C.
12 ;;; SOD 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.
17 ;;; SOD 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.
22 ;;; You should have received a copy of the GNU General Public License
23 ;;; along with SOD; if not, write to the Free Software Foundation,
24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
26 (cl:defpackage #:optparse
27 (:use #:common-lisp #:cl-launch #:sod-utilities))
29 (cl:in-package #:optparse)
31 ;;;--------------------------------------------------------------------------
32 ;;; Program environment things.
35 (defun exit (&optional (code 0) &key abrupt)
36 "End program, returning CODE to the caller."
37 (declare (type (unsigned-byte 32) code))
38 #+sbcl (sb-ext:exit :code code :abort abrupt)
40 (unix::void-syscall ("_exit" c-call:int) code)
42 #+clisp (funcall (if abrupt #'ext:quit #'ext:exit) code)
45 #-(or sbcl cmu clisp ecl)
48 (format *error-output*
49 "~&Exiting unsuccessfully with code ~D.~%" code))
52 (export '(*program-name* *command-line*))
53 (defvar *program-name* "<unknown>"
54 "Program name, as retrieved from the command line.")
55 (defvar *command-line* nil
56 "A list of command-line arguments, including the program name.")
58 (export 'set-command-line-arguments)
59 (defun set-command-line-arguments ()
60 "Retrieve command-line arguments.
62 Set `*command-line*' and `*program-name*'."
65 (cons (or (getenv "CL_LAUNCH_FILE")
66 #+sbcl (car sb-ext:*posix-argv*)
67 #+cmu (car ext:*command-line-strings*)
68 #+clisp (aref (ext:argv) 0)
70 #-(or sbcl cmu clisp ecl) "sod")
73 *program-name* (pathname-name (car *command-line*))))
75 ;;;--------------------------------------------------------------------------
76 ;;; Fancy conditionals.
78 (eval-when (:compile-toplevel :load-toplevel :execute)
79 (defun do-case2-like (kind vform clauses)
80 "Helper function for `case2' and `ecase2'."
81 (with-gensyms (scrutinee argument)
82 `(multiple-value-bind (,scrutinee ,argument) ,vform
83 (declare (ignorable ,argument))
85 ,@(mapcar (lambda (clause)
87 (cases (&optional varx vary) &rest forms)
91 (list `(let ((,(or vary varx) ,argument)
93 `((,varx ,scrutinee))))
98 (defmacro case2 (vform &body clauses)
99 "Switch based on the first value of a form, capturing the second value.
101 VFORM is a form which evaluates to two values, SCRUTINEE and ARGUMENT.
102 The CLAUSES have the form (CASES ([[SCRUVAR] ARGVAR]) FORMS...), where a
103 standard `case' clause has the form (CASES FORMS...). The `case2' form
104 evaluates the VFORM, and compares the SCRUTINEE to the various CASES, in
105 order, just like `case'. If there is a match, then the corresponding
106 FORMs are evaluated with ARGVAR bound to the ARGUMENT and SCRUVAR bound to
107 the SCRUTINEE (where specified). Note the bizarre defaulting behaviour:
108 ARGVAR is less optional than SCRUVAR."
109 (do-case2-like 'case vform clauses))
111 (defmacro ecase2 (vform &body clauses)
112 "Like `case2', but signals an error if no clause matches the SCRUTINEE."
113 (do-case2-like 'ecase vform clauses))
115 ;;;--------------------------------------------------------------------------
119 (defstruct (loc (:predicate locp) (:constructor make-loc (reader writer)))
120 "Locative data type. See `locf' and `ref'."
121 (reader nil :type function)
122 (writer nil :type function))
125 (defmacro locf (place &environment env)
126 "Slightly cheesy locatives.
128 (locf PLACE) returns an object which, using the `ref' function, can be
129 used to read or set the value of PLACE. It's cheesy because it uses
130 closures rather than actually taking the address of something. Also,
131 unlike Zetalisp, we don't overload `car' to do our dirty work."
133 (valtmps valforms newtmps setform getform)
134 (get-setf-expansion place env)
135 `(let* (,@(mapcar #'list valtmps valforms))
136 (make-loc (lambda () ,getform)
137 (lambda (,@newtmps) ,setform)))))
140 (declaim (inline ref (setf ref)))
142 "Fetch the value referred to by a locative."
143 (funcall (loc-reader loc)))
144 (defun (setf ref) (new loc)
145 "Store a new value in the place referred to by a locative."
146 (funcall (loc-writer loc) new))
148 (export 'with-locatives)
149 (defmacro with-locatives (locs &body body)
150 "Evaluate BODY with implicit locatives.
152 LOCS is a list of items of the form (SYM [LOC-EXPR]), where SYM is a
153 symbol and LOC-EXPR evaluates to a locative. If LOC-EXPR is omitted, it
154 defaults to SYM. As an abbreviation for a common case, LOCS may be a
155 symbol instead of a list.
157 The BODY is evaluated in an environment where each SYM is a symbol macro
158 which expands to (ref LOC-EXPR) -- or, in fact, something similar which
159 doesn't break if LOC-EXPR has side-effects. Thus, references, including
160 `setf' forms, fetch or modify the thing referred to by the LOC-EXPR.
161 Useful for covering over where something uses a locative."
162 (setf locs (mapcar (lambda (item)
163 (cond ((atom item) (list item item))
164 ((null (cdr item)) (list (car item) (car item)))
166 (if (listp locs) locs (list locs))))
167 (let ((tt (mapcar (lambda (l) (declare (ignore l)) (gensym)) locs))
168 (ll (mapcar #'cadr locs))
169 (ss (mapcar #'car locs)))
170 `(let (,@(mapcar (lambda (tmp loc) `(,tmp ,loc)) tt ll))
171 (symbol-macrolet (,@(mapcar (lambda (sym tmp)
172 `(,sym (ref ,tmp))) ss tt))
175 ;;;--------------------------------------------------------------------------
176 ;;; Standard error-reporting functions.
179 (defun moan (msg &rest args)
180 "Report an error message in the usual way."
181 (format *error-output* "~&~A: ~?~%" *program-name* msg args))
184 (defun die (&rest args)
185 "Report an error message and exit."
189 ;;;--------------------------------------------------------------------------
190 ;;; The main option parser.
193 (defvar *options* nil
194 "The default list of command-line options.")
196 (export '(option optionp make-option
197 opt-short-name opt-long-name opt-tag opt-negated-tag
198 opt-arg-name opt-arg-optional-p opt-documentation))
205 (print-unreadable-object (o s :type t)
206 (format s "~@[-~C, ~]~@[--~A~]~
207 ~*~@[~2:*~:[=~A~;[=~A]~]~]~
211 (opt-arg-optional-p o)
213 (opt-documentation o)))))
214 (:constructor %make-option)
215 (:constructor make-option
216 (long-name short-name
218 &key (tag (intern (string-upcase long-name) :keyword))
221 doc (documentation doc))))
222 "Describes a command-line option. Slots:
224 LONG-NAME The option's long name. If this is null, the `option' is
225 just a banner to be printed in the program's help text.
227 TAG The value to be returned if this option is encountered. If
228 this is a function, instead, the function is called with the
229 option's argument or nil.
231 NEGATED-TAG As for TAG, but used if the negated form of the option is
232 found. If this is nil (the default), the option cannot be
235 SHORT-NAME The option's short name. This must be a single character, or
236 nil if the option has no short name.
238 ARG-NAME The name of the option's argument, a string. If this is nil,
239 the option doesn't accept an argument. The name is shown in
243 If non-nil, the option's argument is optional. This is
244 ignored unless ARG-NAME is non-null.
247 The help text for this option. It is automatically line-
248 wrapped. If nil, the option is omitted from the help
251 Usually, one won't use make-option, but use the option macro instead."
252 (long-name nil :type (or null string))
254 (negated-tag nil :type t)
255 (short-name nil :type (or null character))
256 (arg-name nil :type (or null string))
257 (arg-optional-p nil :type t)
258 (documentation nil :type (or null string)))
260 (export '(option-parser option-parser-p make-option-parser
261 op-options op-non-option op-long-only-p op-numeric-p
262 op-negated-numeric-p op-negated-p))
263 (defstruct (option-parser
265 (:constructor make-option-parser
266 (&key ((:args argstmp) (cdr *command-line*))
269 ((:numericp numeric-p))
272 &aux (args (cons nil argstmp))
274 (negated-p (or negated-numeric-p
275 (some #'opt-negated-tag
277 "An option parser object. Slots:
279 ARGS The arguments to be parsed. Usually this will be
282 OPTIONS List of option structures describing the acceptable options.
284 NON-OPTION Behaviour when encountering a non-option argument. The
285 default is :skip. Allowable values are:
286 :skip -- pretend that it appeared after the option
287 arguments; this is the default behaviour of GNU getopt
288 :stop -- stop parsing options, leaving the remaining
289 command line unparsed
290 :return -- return :non-option and the argument word
292 NUMERIC-P Non-nil tag (as for options) if numeric options (e.g., -43)
293 are to be allowed. The default is nil. (Anomaly: the
294 keyword for this argument is :numericp.)
297 Non-nil tag (as for options) if numeric options (e.g., -43)
298 can be negated. This is not the same thing as a negative
301 LONG-ONLY-P A misnomer inherited from GNU getopt. Whether to allow
302 long options to begin with a single dash. Short options are
303 still allowed, and may be cuddled as usual. The default is
305 (args nil :type list)
306 (options nil :type list)
307 (non-option :skip :type (or function (member :skip :stop :return)))
308 (next nil :type list)
309 (short-opt nil :type (or null string))
310 (short-opt-index 0 :type fixnum)
311 (short-opt-neg-p nil :type t)
312 (long-only-p nil :type t)
313 (numeric-p nil :type t)
314 (negated-numeric-p nil :type t)
315 (negated-p nil :type t))
317 (export 'option-parse-error)
318 (define-condition option-parse-error (error simple-condition)
321 "Indicates an error found while parsing options.
323 Probably not that useful."))
325 (defun option-parse-error (msg &rest args)
326 "Signal an option-parse-error with the given message and arguments."
327 (error (make-condition 'option-parse-error
329 :format-arguments args)))
331 (export 'option-parse-remainder)
332 (defun option-parse-remainder (op)
333 "Returns the unparsed remainder of the command line."
336 (export 'option-parse-return)
337 (defun option-parse-return (tag &optional argument)
338 "Force a return from `option-parse-next' with TAG and ARGUMENT.
340 This should only be called from an option handler."
341 (throw 'option-parse-return (values tag argument)))
343 (export 'option-parse-next)
344 (defun option-parse-next (op)
345 "Parse and handle the next option from the command-line.
347 This is the main option-parsing function. OP is an option-parser object,
348 initialized appropriately. Returns two values, OPT and ARG: OPT is the
349 tag of the next option read, and ARG is the argument attached to it, or
350 nil if there was no argument. If there are no more options, returns nil
351 twice. Options whose TAG is a function aren't returned; instead, the tag
352 function is called, with the option argument (or nil) as the only
353 argument. It is safe for tag functions to throw out of
354 `option-parse-next', if they desparately need to. (This is the only way
355 to actually get `option-parse-next' to return a function value, should
356 that be what you want. See `option-parse-return' for a way of doing
359 While `option-parse-next' is running, there is a restart `skip-option'
360 which moves on to the next option. Error handlers should use this to
361 resume after parsing errors."
362 (labels ((ret (opt &optional arg)
363 (return-from option-parse-next (values opt arg)))
365 (setf (op-next op) nil)
373 (setf (op-next op) (cdr (op-next op))))
375 (setf (cdr (op-next op)) (cddr (op-next op))))
377 (prog1 (peek-arg) (eat-arg)))
379 (process-option (o name negp &key arg argfunc)
380 (cond ((not (opt-arg-name o))
383 "Option `~A' does not accept arguments"
387 (setf arg (funcall argfunc)))
388 ((opt-arg-optional-p o))
390 (setf arg (get-arg)))
392 (option-parse-error "Option `~A' requires an argument"
394 (let ((how (if negp (opt-negated-tag o) (opt-tag o))))
399 (process-long-option (arg start negp)
400 (when (and (not negp)
402 (> (length arg) (+ start 3))
404 :start1 start :end1 (+ start 3)))
408 (eqpos (position #\= arg :start start))
409 (len (or eqpos (length arg)))
410 (optname (subseq arg 0 len))
411 (len-2 (- len start)))
412 (dolist (o (op-options op))
413 (cond ((or (not (stringp (opt-long-name o)))
414 (and negp (not (opt-negated-tag o)))
415 (< (length (opt-long-name o)) len-2)
416 (string/= optname (opt-long-name o)
417 :start1 start :end2 len-2)))
418 ((= (length (opt-long-name o)) len-2)
419 (setf matches (list o))
423 (cond ((null matches)
424 (option-parse-error "Unknown option `~A'" optname))
427 #.(concatenate 'string
428 "Ambiguous long option `~A' -- "
432 (mapcar #'opt-long-name matches))))
433 (process-option (car matches)
437 (subseq arg (1+ eqpos)))))))
439 (catch 'option-parse-return
441 (with-simple-restart (skip-option "Skip this bogus option.")
444 ;; We're embroiled in short options: handle them.
446 (if (>= (op-short-opt-index op) (length (op-short-opt op)))
447 (setf (op-short-opt op) nil)
448 (let* ((str (op-short-opt op))
449 (i (op-short-opt-index op))
451 (negp (op-short-opt-neg-p op))
452 (name (format nil "~C~A" (if negp #\+ #\-) ch))
453 (o (find ch (op-options op) :key #'opt-short-name)))
455 (setf (op-short-opt-index op) i)
457 (and negp (not (opt-negated-tag o))))
458 (option-parse-error "Unknown option `~A'" name))
463 (and (< i (length str))
467 (setf (op-short-opt op)
470 ;; End of the list. Say we've finished.
474 ;; Process the next option.
476 (let ((arg (peek-arg)))
479 ;; Non-option. Decide what to do.
480 ((or (<= (length arg) 1)
481 (and (char/= (char arg 0) #\-)
482 (or (char/= (char arg 0) #\+)
483 (not (op-negated-p op)))))
484 (case (op-non-option op)
488 (ret :non-option arg))
490 (funcall (op-non-option op) arg))))
492 ;; Double-hyphen. Stop right now.
497 ;; Numbers. Check these before long options, since `--43'
498 ;; is not a long option.
499 ((and (op-numeric-p op)
500 (or (char= (char arg 0) #\-)
501 (op-negated-numeric-p op))
502 (or (and (digit-char-p (char arg 1))
503 (every #'digit-char-p (subseq arg 2)))
504 (and (or (char= (char arg 1) #\-)
505 (char= (char arg 1) #\+))
507 (digit-char-p (char arg 2))
508 (every #'digit-char-p (subseq arg 3)))))
510 (let ((negp (char= (char arg 0) #\+))
511 (num (parse-integer arg :start 1)))
512 (when (and negp (eq (op-negated-numeric-p op) :-))
516 (op-negated-numeric-p op)
520 (ret (if negp :negated-numeric :numeric) num)))))
522 ;; Long option. Find the matching option-spec and process
524 ((and (char= (char arg 0) #\-)
525 (char= (char arg 1) #\-))
527 (process-long-option arg 2 nil))
529 ;; Short options. All that's left.
532 (let ((negp (char= (char arg 0) #\+))
534 (cond ((and (op-long-only-p op)
535 (not (member ch (op-options op)
536 :key #'opt-short-name)))
537 (process-long-option arg 1 negp))
539 (setf (op-short-opt op) arg
540 (op-short-opt-index op) 1
541 (op-short-opt-neg-p op) negp))))))))))))))
543 (export 'option-parse-try)
544 (defmacro option-parse-try (&body body)
545 "Report errors encountered while parsing options, and try to continue.
547 Also establishes a restart `stop-parsing'. Returns t if parsing completed
548 successfully, or nil if errors occurred."
549 (with-gensyms (retcode)
557 (dolist (rn '(skip-option stop-parsing))
558 (let ((r (find-restart rn)))
559 (when r (invoke-restart r)))))))
562 :report "Give up parsing options."
563 (setf ,retcode nil)))
566 (export 'with-unix-error-reporting)
567 (defmacro with-unix-error-reporting ((&key) &body body)
568 "Evaluate BODY with errors reported in the standard Unix fashion."
572 (simple-condition (,cond)
574 (simple-condition-format-control ,cond)
575 (simple-condition-format-arguments ,cond)))
579 ;;;--------------------------------------------------------------------------
580 ;;; Standard option handlers.
582 (export 'defopthandler)
583 (defmacro defopthandler (name (var &optional (arg (gensym)))
586 "Define an option handler function NAME.
588 Option handlers update a generalized variable, which may be referred to as
589 VAR in the BODY, based on some parameters (the ARGS) and the value of an
590 option-argument named ARG."
591 (let ((func (intern (format nil "OPTHANDLER/~:@(~A~)" name))))
592 (multiple-value-bind (docs decls body) (parse-body body)
594 (setf (get ',name 'opthandler) ',func)
595 (defun ,func (,var ,arg ,@args)
597 (declare (ignorable ,arg))
602 (defun parse-c-integer (string &key radix (start 0) end)
603 "Parse (a substring of) STRING according to the standard C rules.
605 Well, almost: the 0 and 0x prefixes are accepted, but so too are
606 0o (Haskell) and 0b (original); also RADIX_DIGITS is accepted, for any
607 radix between 2 and 36. Prefixes are only accepted if RADIX is nil.
608 Returns two values: the integer parsed (or nil if there wasn't enough for
609 a sensible parse), and the index following the characters of the integer."
610 (unless end (setf end (length string)))
611 (labels ((simple (i r goodp sgn)
615 (digit-char-p (char string i) r))
616 (parse-integer string
621 (values (if a (* sgn a) (and goodp 0)) i)))
624 (cond (r (simple i r nil sgn))
625 ((>= i end) (values nil i))
626 ((and (char= (char string i) #\0)
628 (case (char string (1+ i))
629 (#\x (simple (+ i 2) 16 nil sgn))
630 (#\o (simple (+ i 2) 8 nil sgn))
631 (#\b (simple (+ i 2) 2 nil sgn))
632 (t (simple (1+ i) 8 t sgn))))
637 (cond ((not r) (values nil i))
639 (char= (char string i) #\_)
641 (simple (1+ i) r nil sgn))
643 (values (* r sgn) i))))))))
645 (cond ((>= start end) (values nil start))
646 ((char= (char string start) #\-)
647 (get-radix (1+ start) radix -1))
648 ((char= (char string start) #\+)
649 (get-radix (1+ start) radix +1))
651 (get-radix start radix +1)))))
653 (export 'invoke-option-handler)
654 (defun invoke-option-handler (handler loc arg args)
655 "Call HANDLER, giving it LOC to update, the option-argument ARG, and the
657 (apply (if (functionp handler) handler
658 (fdefinition (get handler 'opthandler)))
661 ;;;--------------------------------------------------------------------------
662 ;;; Built-in option handlers.
665 (defopthandler set (var) (&optional (value t))
666 "Sets VAR to VALUE; defaults to t."
670 (defopthandler clear (var) (&optional (value nil))
671 "Sets VAR to VALUE; defaults to nil."
675 (defopthandler inc (var) (&optional max (step 1))
676 "Increments VAR by STEP (defaults to 1), but not greater than MAX (default
677 nil for no maximum). No errors are signalled."
679 (when (and max (>= var max))
683 (defopthandler dec (var) (&optional min (step 1))
684 "Decrements VAR by STEP (defaults to 1), but not less than MIN (default nil
685 for no maximum). No errors are signalled."
687 (when (and min (<= var min))
691 (defopthandler read (var arg) ()
692 "Stores in VAR the Lisp object found by reading the ARG.
694 Evaluation is forbidden while reading ARG. If there is an error during
695 reading, an error of type option-parse-error is signalled."
697 (let ((*read-eval* nil))
698 (multiple-value-bind (x end) (read-from-string arg t)
699 (unless (>= end (length arg))
700 (option-parse-error "Junk at end of argument `~A'" arg))
703 (option-parse-error (format nil "~A" cond)))))
706 (defopthandler int (var arg) (&key radix min max)
707 "Stores in VAR the integer read from the ARG.
709 Integers are parsed according to C rules, which is normal in Unix; the
710 RADIX may be nil to allow radix prefixes, or an integer between 2 and 36.
711 An option-parse-error is signalled if the ARG is not a valid integer, or
712 if it is not between MIN and MAX (either of which may be nil if no lower
713 resp. upper bound is wanted)."
714 (multiple-value-bind (v end) (parse-c-integer arg :radix radix)
715 (unless (and v (>= end (length arg)))
716 (option-parse-error "Bad integer `~A'" arg))
717 (when (or (and min (< v min))
720 #.(concatenate 'string
721 "Integer ~A out of range "
722 "(must have ~@[~D <= ~]x~@[ <= ~D~])")
727 (defopthandler string (var arg) ()
728 "Stores ARG in VAR, just as it is."
732 (defopthandler keyword (var arg) (&optional (valid t))
733 "Converts ARG into a keyword.
735 If VALID is t, then any ARG string is acceptable: the argument is
736 uppercased and interned in the keyword package. If VALID is a list, then
737 we ensure that ARG matches one of the elements of the list; unambigious
738 abbreviations are allowed."
741 (setf var (intern (string-upcase arg) :keyword)))
744 (guess (string-upcase arg))
747 (let* ((kn (symbol-name k))
749 (cond ((string= kn guess)
750 (setf matches (list k))
753 (string= guess kn :end2 len))
757 (option-parse-error #.(concatenate 'string
758 "Argument `~A' invalid: "
762 ((null (cdr matches))
763 (setf var (car matches)))
765 (option-parse-error #.(concatenate 'string
766 "Argument `~A' ambiguous: "
772 (defopthandler list (var arg) (&optional handler &rest handler-args)
773 "Collect ARGs in a list at VAR.
775 ARGs are translated by the HANDLER first, if specified. If not, it's as
776 if you asked for `string'."
778 (invoke-option-handler handler (locf arg) arg handler-args))
779 (setf var (nconc var (list arg))))
781 ;;;--------------------------------------------------------------------------
782 ;;; Option descriptions.
784 (export 'defoptmacro)
785 (defmacro defoptmacro (name args &body body)
786 "Defines an option macro NAME.
788 Option macros should produce a list of expressions producing one option
791 (setf (get ',name 'optmacro) (lambda ,args ,@body))
794 (export 'parse-option-form)
795 (eval-when (:compile-toplevel :load-toplevel :execute)
796 (defun parse-option-form (form)
797 "Does the heavy lifting for parsing an option form.
799 See the docstring for the `option' macro for details of the syntax."
801 (cond ((stringp form) form)
802 ((null (cdr form)) (car form))
803 (t `(format nil ,@form))))
807 (stringp (car form))))))
808 (cond ((stringp form)
809 `(%make-option :documentation ,form))
811 (error "option form must be string or list"))
812 ((and (docp (car form)) (null (cdr form)))
813 `(%make-option :documentation ,(doc (car form))))
815 (let (long-name short-name
816 arg-name arg-optional-p
820 (cond ((and (or (not tag) (not negated-tag))
823 (member (car f) '(lambda function)))))
827 ((and (not long-name)
831 (setf long-name (if (stringp f) f
832 (format nil "~(~A~)" f))))
833 ((and (not short-name)
839 ((and (consp f) (symbolp (car f)))
841 (:short-name (setf short-name (cadr f)))
842 (:long-name (setf long-name (cadr f)))
843 (:tag (setf tag (cadr f)))
844 (:negated-tag (setf negated-tag (cadr f)))
845 (:arg (setf arg-name (cadr f)))
846 (:opt-arg (setf arg-name (cadr f))
847 (setf arg-optional-p t))
848 (:doc (setf doc (doc (cdr f))))
849 (t (let ((handler (get (car f) 'opthandler)))
851 (error "No handler `~S' defined." (car f)))
852 (let* ((var (cadr f))
854 (thunk `#'(lambda (,arg)
855 (,handler (locf ,var)
859 (setf negated-tag thunk)
860 (setf tag thunk)))))))
862 (error "Unexpected thing ~S in option form." f))))
863 `(make-option ,long-name ,short-name ,arg-name
864 ,@(and arg-optional-p `(:arg-optional-p t))
865 ,@(and tag `(:tag ,tag))
866 ,@(and negated-tag `(:negated-tag ,negated-tag))
867 ,@(and doc `(:documentation ,doc)))))))))
870 (defmacro options (&rest optlist)
871 "More convenient way of initializing options. The OPTLIST is a list of
872 OPTFORMS. Each OPTFORM is one of the following:
874 STRING A banner to print.
876 SYMBOL or (SYMBOL STUFF...)
877 If SYMBOL is an optform macro, the result of invoking it.
879 (...) A full option-form. See below.
881 Full option-forms are a list of the following kinds of items.
889 Set the appropriate slot of the option to the given value.
890 The argument is evaluated.
892 (:doc FORMAT-CONTROL ARGUMENTS...)
893 As for (:doc (format nil FORMAT-CONTROL ARGUMENTS...)).
895 KEYWORD, (function ...), (lambda ...)
896 If no TAG is set yet, then as a TAG; otherwise as the
899 STRING (or SYMBOL or RATIONAL)
900 If no LONG-NAME seen yet, then the LONG-NAME. For symbols
901 and rationals, the item is converted to a string and squashed
904 CHARACTER If no SHORT-NAME, then the SHORT-NAME.
906 STRING or (STRING STUFF...)
907 If no DOCUMENTATION set yet, then the DOCUMENTATION string,
908 as for (:doc STRING STUFF...)
911 Set the ARG-NAME, and also set ARG-OPTIONAL-P.
913 (HANDLER VAR ARGS...)
914 If no TAG is set yet, attach the HANDLER to this option,
915 giving it ARGS. Otherwise, set the NEGATED-TAG."
917 `(list ,@(mapcan (lambda (form)
920 (cond ((symbolp form) (values form nil))
921 ((and (consp form) (symbolp (car form)))
922 (values (car form) (cdr form)))
923 (t (values nil nil)))
924 (let ((macro (and sym (get sym 'optmacro))))
927 (list (parse-option-form form))))))
930 ;;;--------------------------------------------------------------------------
931 ;;; Support stuff for help and usage messages.
933 (defun print-text (string
935 (stream *standard-output*)
939 "Prints STRING to a pretty-printed STREAM, breaking it at whitespace and
940 newlines in the obvious way. Stuff between square brackets is not broken:
941 this makes usage messages work better."
946 (write-string string stream :start start :end i)
948 (unless end (setf end (length string)))
953 (let ((ch (char string i)))
954 (cond ((char= ch #\newline)
957 (pprint-newline :mandatory stream))
958 ((whitespace-char-p ch)
964 (pprint-newline :fill stream))
968 (#\] (when (plusp nest) (decf nest))))))
971 (export 'simple-usage)
972 (defun simple-usage (opts &optional mandatory-args)
973 "Build a simple usage list from a list of options, and (optionally)
974 mandatory argument names."
975 (let (short-simple long-simple short-arg long-arg)
977 (cond ((not (and (opt-documentation o)
979 ((and (opt-short-name o) (opt-arg-name o))
982 (push o short-simple))
986 (push o long-simple))))
988 (nconc (and short-simple
989 (list (format nil "[-~{~C~}]"
990 (sort (mapcar #'opt-short-name short-simple)
994 (format nil "[--~A]" (opt-long-name o)))
995 (sort long-simple #'string< :key #'opt-long-name)))
998 (format nil "~:[[-~C ~A]~;[-~C[~A]]~]"
999 (opt-arg-optional-p o)
1002 (sort short-arg #'char-lessp
1003 :key #'opt-short-name)))
1006 (format nil "~:[[--~A ~A]~;[--~A[=~A]]~]"
1007 (opt-arg-optional-p o)
1010 (sort long-arg #'string-lessp
1011 :key #'opt-long-name)))
1012 (if (listp mandatory-args)
1014 (list mandatory-args))))))
1016 (export 'show-usage)
1017 (defun show-usage (prog usage &optional (stream *standard-output*))
1018 "Basic usage-showing function.
1020 PROG is the program name, probably from `*program-name*'. USAGE is a list
1021 of possible usages of the program, each of which is a list of items to be
1022 supplied by the user. In simple cases, a single string is sufficient."
1023 (pprint-logical-block (stream nil :prefix "Usage: ")
1024 (dolist (u (if (listp usage) usage (list usage)))
1025 (pprint-logical-block (stream nil
1026 :prefix (concatenate 'string prog " "))
1027 (format stream "~{~A~^ ~:_~}" (if (listp u) u (list u))))))
1030 (defun show-options-help (opts &optional (stream *standard-output*))
1031 "Write help for OPTS to the STREAM.
1033 This is the core of the `show-help' function."
1036 (let ((doc (opt-documentation o)))
1038 ((not (opt-long-name o))
1041 (setf newlinep nil))
1042 (pprint-logical-block (stream nil)
1043 (print-text doc stream))
1047 (pprint-logical-block (stream nil :prefix " ")
1048 (format stream "~:[ ~;-~:*~C,~] --~A"
1051 (when (opt-arg-name o)
1052 (format stream "~:[=~A~;[=~A]~]"
1053 (opt-arg-optional-p o)
1055 (write-string " " stream)
1056 (pprint-tab :line 30 1 stream)
1057 (pprint-indent :block 30 stream)
1058 (print-text doc stream))
1059 (terpri stream)))))))
1062 (defun show-help (prog ver usage opts &optional (stream *standard-output*))
1063 "Basic help-showing function.
1065 PROG is the program name, probably from `*program-name*'. VER is the
1066 program's version number. USAGE is a list of the possible usages of the
1067 program, each of which may be a list of items to be supplied. OPTS is the
1068 list of supported options, as provided to the options parser. STREAM is
1069 the stream to write on."
1070 (format stream "~A, version ~A~2%" prog ver)
1071 (show-usage prog usage stream)
1073 (show-options-help opts stream))
1075 (export 'sanity-check-option-list)
1076 (defun sanity-check-option-list (opts)
1077 "Check the option list OPTS for basic sanity. Reused short and long option
1078 names are diagnosed. Maybe other problems will be reported later.
1079 Returns a list of warning strings."
1080 (let ((problems nil)
1081 (longs (make-hash-table :test #'equal))
1082 (shorts (make-hash-table)))
1083 (flet ((problem (msg &rest args)
1084 (push (apply #'format nil msg args) problems)))
1086 (push o (gethash (opt-long-name o) longs))
1087 (push o (gethash (opt-short-name o) shorts)))
1088 (maphash (lambda (k v)
1089 (when (and k (cdr v))
1090 (problem "Long name `--~A' reused in ~S" k v)))
1092 (maphash (lambda (k v)
1093 (when (and k (cdr v))
1094 (problem "Short name `-~C' reused in ~S" k v)))
1098 ;;;--------------------------------------------------------------------------
1099 ;;; Full program descriptions.
1101 (export '(*help* *version* *usage*))
1102 (defvar *help* nil "Help text describing the program.")
1103 (defvar *version* "<unreleased>" "The program's version number.")
1104 (defvar *usage* nil "A usage summary string")
1107 (defun do-usage (&optional (stream *standard-output*))
1108 (show-usage *program-name* *usage* stream))
1112 (do-usage *error-output*)
1115 (defun opt-help (arg)
1116 (declare (ignore arg))
1117 (show-help *program-name* *version* *usage* *options*)
1119 (string (terpri) (write-string *help*))
1121 ((or function symbol) (terpri) (funcall *help*)))
1124 (defun opt-version (arg)
1125 (declare (ignore arg))
1126 (format t "~A, version ~A~%" *program-name* *version*)
1128 (defun opt-usage (arg)
1129 (declare (ignore arg))
1133 (export 'help-options)
1134 (defoptmacro help-options (&key (short-help #\h)
1137 "Inserts a standard help options collection in an options list."
1138 (flet ((shortform (char)
1139 (and char (list char))))
1143 (,@(shortform short-help) "help" #'opt-help
1144 "Show this help message.")
1145 (,@(shortform short-version) "version" #'opt-version
1146 ("Show ~A's version number." *program-name*))
1147 (,@(shortform short-usage) "usage" #'opt-usage
1148 ("Show a very brief usage summary for ~A." *program-name*))))))
1150 (export 'define-program)
1151 (defun define-program (&key
1152 (program-name nil progp)
1154 (version nil versionp)
1156 (full-usage nil fullp)
1157 (options nil optsp))
1158 "Sets up all the required things a program needs to have to parse options
1159 and respond to them properly."
1160 (when progp (setf *program-name* program-name))
1161 (when helpp (setf *help* help))
1162 (when versionp (setf *version* version))
1163 (when optsp (setf *options* options))
1164 (cond ((and usagep fullp) (error "conflicting options"))
1165 (usagep (setf *usage* (simple-usage *options* usage)))
1166 (fullp (setf *usage* full-usage))))
1168 (export 'do-options)
1169 (defmacro do-options ((&key (parser '(make-option-parser)))
1171 "Handy all-in-one options parser macro.
1173 PARSER defaults to a new options parser using the preset default options
1174 structure. The CLAUSES are `case2'-like clauses to match options, and
1175 must be exhaustive. If there is a clause (nil (REST) FORMS...) then the
1176 FORMS are evaluated after parsing is done with REST bound to the remaining
1177 command-line arguments."
1181 (,(if (find t clauses :key #'car) 'case2 'ecase2)
1182 (option-parse-next ,parser)
1184 ,@(remove-if #'null clauses :key #'car)))
1185 ,@(let ((tail (find nil clauses :key #'car)))
1187 (destructuring-bind ((&optional arg) &rest forms) (cdr tail)
1189 (list `(let ((,arg (option-parse-remainder ,parser)))
1193 ;;;----- That's all, folks --------------------------------------------------