;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
-;;;
+;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
-;;;
+;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
#:op-negated-numeric-p #:op-negated-p
#:option-parse-error
#:option-parse-remainder #:option-parse-next #:option-parse-try
- #:with-unix-error-reporting
+ #:with-unix-error-reporting #:option-parse-return
#:defopthandler #:invoke-option-handler
#:set #:clear #:inc #:dec #:read #:int #:string
#:keyword #:list
#:parse-option-form #:options
#:simple-usage #:show-usage #:show-version #:show-help
- #:sanity-check-option-list))
+ #:sanity-check-option-list
+ #:*help* #:*version* #:*usage* #:*options*
+ #:do-options #:help-options
+ #:define-program #:do-usage #:die-usage))
(in-package #:optparse)
(defun moan (msg &rest args)
"Report an error message in the usual way."
(format *error-output* "~&~A: ~?~%" *program-name* msg args))
+
(defun die (&rest args)
"Report an error message and exit."
(apply #'moan args)
;;;--------------------------------------------------------------------------
;;; The main option parser.
+(defvar *options* nil)
+
(defstruct (option (:predicate optionp)
(:conc-name opt-)
(:print-function
(documentation doc))))
"Describes a command-line option. Slots:
-LONG-NAME The option's long name. If this is null, the `option' is
- just a banner to be printed in the program's help text.
+ LONG-NAME The option's long name. If this is null, the `option' is
+ just a banner to be printed in the program's help text.
-TAG The value to be returned if this option is encountered. If
- this is a function, instead, the function is called with the
- option's argument or nil.
+ TAG The value to be returned if this option is encountered. If
+ this is a function, instead, the function is called with the
+ option's argument or nil.
-NEGATED-TAG As for TAG, but used if the negated form of the option is
- found. If this is nil (the default), the option cannot be
- negated.
+ NEGATED-TAG As for TAG, but used if the negated form of the option is
+ found. If this is nil (the default), the option cannot be
+ negated.
-SHORT-NAME The option's short name. This must be a single character, or
- nil if the option has no short name.
+ SHORT-NAME The option's short name. This must be a single character, or
+ nil if the option has no short name.
-ARG-NAME The name of the option's argument, a string. If this is nil,
- the option doesn't accept an argument. The name is shown in
- the help text.
+ ARG-NAME The name of the option's argument, a string. If this is nil,
+ the option doesn't accept an argument. The name is shown in
+ the help text.
-ARG-OPTIONAL-P If non-nil, the option's argument is optional. This is
- ignored unless ARG-NAME is non-null.
+ ARG-OPTIONAL-P
+ If non-nil, the option's argument is optional. This is
+ ignored unless ARG-NAME is non-null.
-DOCUMENTATION The help text for this option. It is automatically
- line-wrapped. If nil, the option is omitted from the help
- text.
+ DOCUMENTATION
+ The help text for this option. It is automatically line-
+ wrapped. If nil, the option is omitted from the help
+ text.
-Usually, one won't use make-option, but use the option macro instead."
+ Usually, one won't use make-option, but use the option macro instead."
(long-name nil :type (or null string))
(tag nil :type t)
(negated-tag nil :type t)
(defstruct (option-parser (:conc-name op-)
(:constructor make-option-parser
- (argstmp
- options
- &key
+ (&key
+ ((:args argstmp)
+ (cdr *command-line-strings*))
+ (options *options*)
(non-option :skip)
((:numericp numeric-p))
negated-numeric-p
options))))))
"An option parser object. Slots:
-ARGS The arguments to be parsed. Usually this will be
- *command-line-strings*.
+ ARGS The arguments to be parsed. Usually this will be
+ *command-line-strings*.
-OPTIONS List of option structures describing the acceptable options.
+ OPTIONS List of option structures describing the acceptable options.
-NON-OPTION Behaviour when encountering a non-option argument. The
- default is :skip. Allowable values are:
- :skip -- pretend that it appeared after the option
- arguments; this is the default behaviour of GNU getopt
- :stop -- stop parsing options, leaving the remaining
- command line unparsed
- :return -- return :non-option and the argument word
+ NON-OPTION Behaviour when encountering a non-option argument. The
+ default is :skip. Allowable values are:
+ :skip -- pretend that it appeared after the option
+ arguments; this is the default behaviour of GNU getopt
+ :stop -- stop parsing options, leaving the remaining
+ command line unparsed
+ :return -- return :non-option and the argument word
-NUMERIC-P Non-nil tag (as for options) if numeric options (e.g., -43)
- are to be allowed. The default is nil. (Anomaly: the
- keyword for this argument is :numericp.)
+ NUMERIC-P Non-nil tag (as for options) if numeric options (e.g., -43)
+ are to be allowed. The default is nil. (Anomaly: the
+ keyword for this argument is :numericp.)
-NEGATED-NUMERIC-P
- Non-nil tag (as for options) if numeric options (e.g., -43)
- can be negated. This is not the same thing as a negative
- numeric option!
+ NEGATED-NUMERIC-P
+ Non-nil tag (as for options) if numeric options (e.g., -43)
+ can be negated. This is not the same thing as a negative
+ numeric option!
-LONG-ONLY-P A misnomer inherited from GNU getopt. Whether to allow
- long options to begin with a single dash. Short options are
- still allowed, and may be cuddled as usual. The default is
- nil."
+ LONG-ONLY-P A misnomer inherited from GNU getopt. Whether to allow
+ long options to begin with a single dash. Short options are
+ still allowed, and may be cuddled as usual. The default is
+ nil."
(args nil :type list)
(options nil :type list)
(non-option :skip :type (or function (member :skip :stop :return)))
(define-condition option-parse-error (error simple-condition)
()
- (:documentation "Indicates an error found while parsing options. Probably
-not that useful."))
+ (:documentation
+ "Indicates an error found while parsing options. Probably not that
+ useful."))
(defun option-parse-error (msg &rest args)
"Signal an option-parse-error with the given message and arguments."
"Returns the unparsed remainder of the command line."
(cdr (op-args op)))
+(defun option-parse-return (tag &optional argument)
+ "Should be called from an option handler: forces a return from the
+ immediately enclosing `option-parse-next' with the given TAG and
+ ARGUMENT."
+ (throw 'option-parse-return (values tag argument)))
+
(defun option-parse-next (op)
"The main option-parsing function. OP is an option-parser object,
-initialized appropriately. Returns two values, OPT and ARG: OPT is the tag
-of the next option read, and ARG is the argument attached to it, or nil if
-there was no argument. If there are no more options, returns nil twice.
-Options whose TAG is a function aren't returned; instead, the tag function is
-called, with the option argument (or nil) as the only argument. It is safe
-for tag functions to throw out of option-parse-next, if they desparately need
-to. (This is the only way to actually get option-parse-next to return a
-function value, should that be what you want.)
-
-While option-parse-next is running, there is a restart `skip-option' which
-moves on to the next option. Error handlers should use this to resume after
-parsing errors."
- (loop
- (labels ((ret (opt &optional arg)
- (return-from option-parse-next (values opt arg)))
- (finished ()
- (setf (op-next op) nil)
- (ret nil nil))
- (peek-arg ()
- (cadr (op-next op)))
- (more-args-p ()
- (and (op-next op)
- (cdr (op-next op))))
- (skip-arg ()
- (setf (op-next op) (cdr (op-next op))))
- (eat-arg ()
- (setf (cdr (op-next op)) (cddr (op-next op))))
- (get-arg ()
- (prog1 (peek-arg) (eat-arg)))
- (process-option (o name negp &key arg argfunc)
- (cond ((not (opt-arg-name o))
- (when arg
- (option-parse-error
- "Option `~A' does not accept arguments"
- name)))
- (arg)
- (argfunc
- (setf arg (funcall argfunc)))
- ((opt-arg-optional-p o))
- ((more-args-p)
- (setf arg (get-arg)))
- (t
- (option-parse-error "Option `~A' requires an argument"
- name)))
- (let ((how (if negp (opt-negated-tag o) (opt-tag o))))
- (if (functionp how)
- (funcall how arg)
- (ret how arg))))
- (process-long-option (arg start negp)
- (when (and (not negp)
- (op-negated-p op)
- (> (length arg) (+ start 3))
- (string= arg "no-"
- :start1 start :end1 (+ start 3)))
- (incf start 3)
- (setf negp t))
- (let* ((matches nil)
- (eqpos (position #\= arg :start start))
- (len (or eqpos (length arg)))
- (optname (subseq arg 0 len))
- (len-2 (- len start)))
- (dolist (o (op-options op))
- (cond ((or (not (stringp (opt-long-name o)))
- (and negp (not (opt-negated-tag o)))
- (< (length (opt-long-name o)) len-2)
- (string/= optname (opt-long-name o)
- :start1 start :end2 len-2)))
- ((= (length (opt-long-name o)) len-2)
- (setf matches (list o))
- (return))
- (t
- (push o matches))))
- (cond ((null matches)
- (option-parse-error "Unknown option `~A'" optname))
- ((cdr matches)
- (option-parse-error
- "~
+ initialized appropriately. Returns two values, OPT and ARG: OPT is the
+ tag of the next option read, and ARG is the argument attached to it, or
+ nil if there was no argument. If there are no more options, returns nil
+ twice. Options whose TAG is a function aren't returned; instead, the tag
+ function is called, with the option argument (or nil) as the only
+ argument. It is safe for tag functions to throw out of option-parse-next,
+ if they desparately need to. (This is the only way to actually get
+ option-parse-next to return a function value, should that be what you
+ want. See `option-parse-return' for a way of doing this.)
+
+ While option-parse-next is running, there is a restart `skip-option' which
+ moves on to the next option. Error handlers should use this to resume
+ after parsing errors."
+ (labels ((ret (opt &optional arg)
+ (return-from option-parse-next (values opt arg)))
+ (finished ()
+ (setf (op-next op) nil)
+ (ret nil nil))
+ (peek-arg ()
+ (cadr (op-next op)))
+ (more-args-p ()
+ (and (op-next op)
+ (cdr (op-next op))))
+ (skip-arg ()
+ (setf (op-next op) (cdr (op-next op))))
+ (eat-arg ()
+ (setf (cdr (op-next op)) (cddr (op-next op))))
+ (get-arg ()
+ (prog1 (peek-arg) (eat-arg)))
+ (process-option (o name negp &key arg argfunc)
+ (cond ((not (opt-arg-name o))
+ (when arg
+ (option-parse-error
+ "Option `~A' does not accept arguments"
+ name)))
+ (arg)
+ (argfunc
+ (setf arg (funcall argfunc)))
+ ((opt-arg-optional-p o))
+ ((more-args-p)
+ (setf arg (get-arg)))
+ (t
+ (option-parse-error "Option `~A' requires an argument"
+ name)))
+ (let ((how (if negp (opt-negated-tag o) (opt-tag o))))
+ (if (functionp how)
+ (funcall how arg)
+ (ret how arg))))
+ (process-long-option (arg start negp)
+ (when (and (not negp)
+ (op-negated-p op)
+ (> (length arg) (+ start 3))
+ (string= arg "no-"
+ :start1 start :end1 (+ start 3)))
+ (incf start 3)
+ (setf negp t))
+ (let* ((matches nil)
+ (eqpos (position #\= arg :start start))
+ (len (or eqpos (length arg)))
+ (optname (subseq arg 0 len))
+ (len-2 (- len start)))
+ (dolist (o (op-options op))
+ (cond ((or (not (stringp (opt-long-name o)))
+ (and negp (not (opt-negated-tag o)))
+ (< (length (opt-long-name o)) len-2)
+ (string/= optname (opt-long-name o)
+ :start1 start :end2 len-2)))
+ ((= (length (opt-long-name o)) len-2)
+ (setf matches (list o))
+ (return))
+ (t
+ (push o matches))))
+ (cond ((null matches)
+ (option-parse-error "Unknown option `~A'" optname))
+ ((cdr matches)
+ (option-parse-error
+ "~
Ambiguous long option `~A' -- could be any of:~{~% --~A~}"
- optname
- (mapcar #'opt-long-name matches))))
- (process-option (car matches)
- optname
- negp
- :arg (and eqpos
- (subseq arg (1+ eqpos)))))))
- (with-simple-restart (skip-option "Skip this bogus option.")
- (cond
- ;;
- ;; We're embroiled in short options: handle them.
- ((op-short-opt op)
- (if (>= (op-short-opt-index op) (length (op-short-opt op)))
- (setf (op-short-opt op) nil)
- (let* ((str (op-short-opt op))
- (i (op-short-opt-index op))
- (ch (char str i))
- (negp (op-short-opt-neg-p op))
- (name (format nil "~C~A" (if negp #\+ #\-) ch))
- (o (find ch (op-options op) :key #'opt-short-name)))
- (incf i)
- (setf (op-short-opt-index op) i)
- (when (or (not o)
- (and negp (not (opt-negated-tag o))))
- (option-parse-error "Unknown option `~A'" name))
- (process-option o
- name
- negp
- :argfunc
- (and (< i (length str))
- (lambda ()
- (prog1
- (subseq str i)
- (setf (op-short-opt op)
- nil))))))))
- ;;
- ;; End of the list. Say we've finished.
- ((not (more-args-p))
- (finished))
- ;;
- ;; Process the next option.
- (t
- (let ((arg (peek-arg)))
- (cond
- ;;
- ;; Non-option. Decide what to do.
- ((or (<= (length arg) 1)
- (and (char/= (char arg 0) #\-)
- (or (char/= (char arg 0) #\+)
- (not (op-negated-p op)))))
- (case (op-non-option op)
- (:skip (skip-arg))
- (:stop (finished))
- (:return (eat-arg)
- (ret :non-option arg))
- (t (eat-arg)
- (funcall (op-non-option op) arg))))
- ;;
- ;; Double-hyphen. Stop right now.
- ((string= arg "--")
- (eat-arg)
- (finished))
- ;;
- ;; Numbers. Check these before long options, since `--43' is
- ;; not a long option.
- ((and (op-numeric-p op)
- (or (char= (char arg 0) #\-)
- (op-negated-numeric-p op))
- (or (and (digit-char-p (char arg 1))
- (every #'digit-char-p (subseq arg 2)))
- (and (or (char= (char arg 1) #\-)
- (char= (char arg 1) #\+))
- (>= (length arg) 3)
- (digit-char-p (char arg 2))
- (every #'digit-char-p (subseq arg 3)))))
- (eat-arg)
- (let ((negp (char= (char arg 0) #\+))
- (num (parse-integer arg :start 1)))
- (when (and negp (eq (op-negated-numeric-p op) :-))
- (setf num (- num))
- (setf negp nil))
- (let ((how (if negp
- (op-negated-numeric-p op)
- (op-numeric-p op))))
- (if (functionp how)
- (funcall how num)
- (ret (if negp :negated-numeric :numeric) num)))))
- ;;
- ;; Long option. Find the matching option-spec and process
- ;; it.
- ((and (char= (char arg 0) #\-)
- (char= (char arg 1) #\-))
- (eat-arg)
- (process-long-option arg 2 nil))
- ;;
- ;; Short options. All that's left.
- (t
- (eat-arg)
- (let ((negp (char= (char arg 0) #\+))
- (ch (char arg 1)))
- (cond ((and (op-long-only-p op)
- (not (member ch (op-options op)
- :key #'opt-short-name)))
- (process-long-option arg 1 negp))
- (t
- (setf (op-short-opt op) arg
- (op-short-opt-index op) 1
- (op-short-opt-neg-p op) negp)))))))))))))
+ optname
+ (mapcar #'opt-long-name matches))))
+ (process-option (car matches)
+ optname
+ negp
+ :arg (and eqpos
+ (subseq arg (1+ eqpos)))))))
+ (catch 'option-parse-return
+ (loop
+ (with-simple-restart (skip-option "Skip this bogus option.")
+ (cond
+ ;;
+ ;; We're embroiled in short options: handle them.
+ ((op-short-opt op)
+ (if (>= (op-short-opt-index op) (length (op-short-opt op)))
+ (setf (op-short-opt op) nil)
+ (let* ((str (op-short-opt op))
+ (i (op-short-opt-index op))
+ (ch (char str i))
+ (negp (op-short-opt-neg-p op))
+ (name (format nil "~C~A" (if negp #\+ #\-) ch))
+ (o (find ch (op-options op) :key #'opt-short-name)))
+ (incf i)
+ (setf (op-short-opt-index op) i)
+ (when (or (not o)
+ (and negp (not (opt-negated-tag o))))
+ (option-parse-error "Unknown option `~A'" name))
+ (process-option o
+ name
+ negp
+ :argfunc
+ (and (< i (length str))
+ (lambda ()
+ (prog1
+ (subseq str i)
+ (setf (op-short-opt op)
+ nil))))))))
+ ;;
+ ;; End of the list. Say we've finished.
+ ((not (more-args-p))
+ (finished))
+ ;;
+ ;; Process the next option.
+ (t
+ (let ((arg (peek-arg)))
+ (cond
+ ;;
+ ;; Non-option. Decide what to do.
+ ((or (<= (length arg) 1)
+ (and (char/= (char arg 0) #\-)
+ (or (char/= (char arg 0) #\+)
+ (not (op-negated-p op)))))
+ (case (op-non-option op)
+ (:skip (skip-arg))
+ (:stop (finished))
+ (:return (eat-arg)
+ (ret :non-option arg))
+ (t (eat-arg)
+ (funcall (op-non-option op) arg))))
+ ;;
+ ;; Double-hyphen. Stop right now.
+ ((string= arg "--")
+ (eat-arg)
+ (finished))
+ ;;
+ ;; Numbers. Check these before long options, since `--43'
+ ;; is not a long option.
+ ((and (op-numeric-p op)
+ (or (char= (char arg 0) #\-)
+ (op-negated-numeric-p op))
+ (or (and (digit-char-p (char arg 1))
+ (every #'digit-char-p (subseq arg 2)))
+ (and (or (char= (char arg 1) #\-)
+ (char= (char arg 1) #\+))
+ (>= (length arg) 3)
+ (digit-char-p (char arg 2))
+ (every #'digit-char-p (subseq arg 3)))))
+ (eat-arg)
+ (let ((negp (char= (char arg 0) #\+))
+ (num (parse-integer arg :start 1)))
+ (when (and negp (eq (op-negated-numeric-p op) :-))
+ (setf num (- num))
+ (setf negp nil))
+ (let ((how (if negp
+ (op-negated-numeric-p op)
+ (op-numeric-p op))))
+ (if (functionp how)
+ (funcall how num)
+ (ret (if negp :negated-numeric :numeric) num)))))
+ ;;
+ ;; Long option. Find the matching option-spec and process
+ ;; it.
+ ((and (char= (char arg 0) #\-)
+ (char= (char arg 1) #\-))
+ (eat-arg)
+ (process-long-option arg 2 nil))
+ ;;
+ ;; Short options. All that's left.
+ (t
+ (eat-arg)
+ (let ((negp (char= (char arg 0) #\+))
+ (ch (char arg 1)))
+ (cond ((and (op-long-only-p op)
+ (not (member ch (op-options op)
+ :key #'opt-short-name)))
+ (process-long-option arg 1 negp))
+ (t
+ (setf (op-short-opt op) arg
+ (op-short-opt-index op) 1
+ (op-short-opt-neg-p op) negp))))))))))))))
(defmacro option-parse-try (&body body)
"Report errors encountered while parsing options, and continue struggling
-along. Also establishes a restart `stop-parsing'. Returns t if parsing
-completed successfully, or nil if errors occurred."
+ along. Also establishes a restart `stop-parsing'. Returns t if parsing
+ completed successfully, or nil if errors occurred."
(with-gensyms (retcode)
`(let ((,retcode t))
(restart-case
`(handler-case
(progn ,@body)
(simple-condition (,cond)
- (die (simple-condition-format-control ,cond)
- (simple-condition-format-arguments ,cond)))
+ (apply #'die
+ (simple-condition-format-control ,cond)
+ (simple-condition-format-arguments ,cond)))
(error (,cond)
(die "~A" ,cond)))))
(&rest args)
&body body)
"Define an option handler function NAME. Option handlers update a
-generalized variable, which may be referred to as VAR in the BODY, based on
-some parameters (the ARGS) and the value of an option-argument named ARG."
+ generalized variable, which may be referred to as VAR in the BODY, based
+ on some parameters (the ARGS) and the value of an option-argument named
+ ARG."
(let ((func (intern (format nil "OPTHANDLER/~:@(~A~)" name))))
- `(progn
- (setf (get ',name 'opthandler) ',func)
- (defun ,func (,var ,arg ,@args)
- (with-locatives ,var
- (declare (ignorable ,arg))
- ,@body))
- ',name)))
+ (with-parsed-body (body decls docs) body
+ `(progn
+ (setf (get ',name 'opthandler) ',func)
+ (defun ,func (,var ,arg ,@args)
+ ,@docs ,@decls
+ (with-locatives ,var
+ (declare (ignorable ,arg))
+ ,@body))
+ ',name))))
(defun parse-c-integer (string &key radix (start 0) end)
"Parse STRING, or at least the parts of it between START and END, according
-to the standard C rules. Well, almost: the 0 and 0x prefixes are accepted,
-but so too are 0o (Haskell) and 0b (original); also RADIX_DIGITS is accepted,
-for any radix between 2 and 36. Prefixes are only accepted if RADIX is nil.
-Returns two values: the integer parsed (or nil if there wasn't enough for a
-sensible parse), and the index following the characters of the integer."
- (unless end (setf end (length string)))
+ to the standard C rules. Well, almost: the 0 and 0x prefixes are
+ accepted, but so too are 0o (Haskell) and 0b (original); also RADIX_DIGITS
+ is accepted, for any radix between 2 and 36. Prefixes are only accepted
+ if RADIX is nil. Returns two values: the integer parsed (or nil if there
+ wasn't enough for a sensible parse), and the index following the
+ characters of the integer."
+ (setf-default end (length string))
(labels ((simple (i r goodp sgn)
(multiple-value-bind
(a i)
(defun invoke-option-handler (handler loc arg args)
"Call the HANDLER function, giving it LOC to update, the option-argument
-ARG, and the remaining ARGS."
+ ARG, and the remaining ARGS."
(apply (if (functionp handler) handler
(fdefinition (get handler 'opthandler)))
loc
arg
args))
+;;;--------------------------------------------------------------------------
+;;; Built-in option handlers.
+
(defopthandler set (var) (&optional (value t))
"Sets VAR to VALUE; defaults to t."
(setf var value))
+
(defopthandler clear (var) (&optional (value nil))
"Sets VAR to VALUE; defaults to nil."
(setf var value))
+
(defopthandler inc (var) (&optional max (step 1))
"Increments VAR by STEP (defaults to 1), but not greater than MAX (default
-nil for no maximum). No errors are signalled."
+ nil for no maximum). No errors are signalled."
(incf var step)
(when (>= var max)
(setf var max)))
+
(defopthandler dec (var) (&optional min (step 1))
"Decrements VAR by STEP (defaults to 1), but not less than MIN (default nil
-for no maximum). No errors are signalled."
+ for no maximum). No errors are signalled."
(decf var step)
(when (<= var min)
(setf var min)))
+
(defopthandler read (var arg) ()
"Stores in VAR the Lisp object found by reading the ARG. Evaluation is
-forbidden while reading ARG. If there is an error during reading, an error
-of type option-parse-error is signalled."
+ forbidden while reading ARG. If there is an error during reading, an
+ error of type option-parse-error is signalled."
(handler-case
(let ((*read-eval* nil))
(multiple-value-bind (x end) (read-from-string arg t)
(setf var x)))
(error (cond)
(option-parse-error (format nil "~A" cond)))))
+
(defopthandler int (var arg) (&key radix min max)
"Stores in VAR the integer read from the ARG. Integers are parsed
-according to C rules, which is normal in Unix; the RADIX may be nil to allow
-radix prefixes, or an integer between 2 and 36. An option-parse-error is
-signalled if the ARG is not a valid integer, or if it is not between MIN and
-MAX (either of which may be nil if no lower resp. upper bound is wanted)."
+ according to C rules, which is normal in Unix; the RADIX may be nil to
+ allow radix prefixes, or an integer between 2 and 36. An
+ option-parse-error is signalled if the ARG is not a valid integer, or if
+ it is not between MIN and MAX (either of which may be nil if no lower
+ resp. upper bound is wanted)."
(multiple-value-bind (v end) (parse-c-integer arg :radix radix)
(unless (and v (>= end (length arg)))
(option-parse-error "Bad integer `~A'" arg))
"Integer ~A out of range (must have ~@[~D <= ~]x~@[ <= ~D~])"
arg min max))
(setf var v)))
+
(defopthandler string (var arg) ()
"Stores ARG in VAR, just as it is."
(setf var arg))
-(defopthandler keyword (var arg) (&rest valid)
- (if (null valid)
- (setf var (intern (string-upcase arg) :keyword))
- (let ((matches nil)
- (guess (string-upcase arg))
- (len (length arg)))
- (dolist (k valid)
- (let* ((kn (symbol-name k))
- (klen (length kn)))
- (cond ((string= kn guess)
- (setf matches (list k))
- (return))
- ((and (< len klen)
- (string= guess kn :end2 len))
- (push k matches)))))
- (case (length matches)
- (0 (option-parse-error "Argument `~A' invalid: must be one of:~
- ~{~%~8T~(~A~)~}"
- arg valid))
- (1 (setf var (car matches)))
- (t (option-parse-error "Argument `~A' ambiguous: may be any of:~
- ~{~%~8T~(~A~)~}"
- arg matches))))))
+
+(defopthandler keyword (var arg) (&optional (valid t))
+ "Converts ARG into a keyword. If VALID is t, then any ARG string is
+ acceptable: the argument is uppercased and interned in the keyword
+ package. If VALID is a list, then we ensure that ARG matches one of the
+ elements of the list; unambigious abbreviations are allowed."
+ (etypecase valid
+ ((member t)
+ (setf var (intern (string-upcase arg) :keyword)))
+ (list
+ (let ((matches nil)
+ (guess (string-upcase arg))
+ (len (length arg)))
+ (dolist (k valid)
+ (let* ((kn (symbol-name k))
+ (klen (length kn)))
+ (cond ((string= kn guess)
+ (setf matches (list k))
+ (return))
+ ((and (< len klen)
+ (string= guess kn :end2 len))
+ (push k matches)))))
+ (cond
+ ((null matches)
+ (option-parse-error "Argument `~A' invalid: must be one of:~
+ ~{~%~8T~(~A~)~}"
+ arg valid))
+ ((null (cdr matches))
+ (setf var (car matches)))
+ (t
+ (option-parse-error "Argument `~A' ambiguous: may be any of:~
+ ~{~%~8T~(~A~)~}"
+ arg matches)))))))
+
(defopthandler list (var arg) (&optional handler &rest handler-args)
"Collect ARGs in a list at VAR. ARGs are translated by the HANDLER first,
-if specified. If not, it's as if you asked for `string'."
+ if specified. If not, it's as if you asked for `string'."
(when handler
(invoke-option-handler handler (locf arg) arg handler-args))
(setf var (nconc var (list arg))))
+;;;--------------------------------------------------------------------------
+;;; Option descriptions.
+
+(defmacro defoptmacro (name args &body body)
+ "Defines an option macro NAME. Option macros should produce a list of
+ expressions producing one option structure each."
+ `(progn
+ (setf (get ',name 'optmacro) (lambda ,args ,@body))
+ ',name))
+
(compile-time-defun parse-option-form (form)
"Does the heavy lifting for parsing an option form. See the docstring for
-the `option' macro for details of the syntax."
+ the `option' macro for details of the syntax."
(flet ((doc (form)
(cond ((stringp form) form)
((null (cdr form)) (car form))
(or (stringp form)
(and (consp form)
(stringp (car form))))))
- (if (and (docp (car form))
- (null (cdr form)))
- `(%make-option :documentation ,(doc (car form)))
- (let (long-name short-name
- arg-name arg-optional-p
- tag negated-tag
- doc)
- (dolist (f form)
- (cond ((and (or (not tag) (not negated-tag))
- (or (keywordp f)
- (and (consp f)
- (member (car f) '(lambda function)))))
- (if tag
- (setf negated-tag f)
- (setf tag f)))
- ((and (not long-name)
- (or (rationalp f)
- (symbolp f)
- (stringp f)))
- (setf long-name (if (stringp f) f
- (format nil "~(~A~)" f))))
- ((and (not short-name)
- (characterp f))
- (setf short-name f))
- ((and (not doc)
- (docp f))
- (setf doc (doc f)))
- ((and (consp f) (symbolp (car f)))
- (case (car f)
- (:arg (setf arg-name (cadr f)))
- (:opt-arg (setf arg-name (cadr f))
- (setf arg-optional-p t))
- (:doc (setf doc (doc (cdr f))))
- (t (let ((handler (get (car f) 'opthandler)))
- (unless handler
- (error "No handler `~S' defined." (car f)))
- (let* ((var (cadr f))
- (arg (gensym))
- (thunk `#'(lambda (,arg)
- (,handler (locf ,var)
- ,arg
- ,@(cddr f)))))
- (if tag
- (setf negated-tag thunk)
- (setf tag thunk)))))))
- (t
- (error "Unexpected thing ~S in option form." f))))
- `(make-option ,long-name ,short-name ,arg-name
- ,@(and arg-optional-p `(:arg-optional-p t))
- ,@(and tag `(:tag ,tag))
- ,@(and negated-tag `(:negated-tag ,negated-tag))
- ,@(and doc `(:documentation ,doc)))))))
+ (cond ((stringp form)
+ `(%make-option :documentation ,form))
+ ((not (listp form))
+ (error "option form must be string or list"))
+ ((and (docp (car form)) (null (cdr form)))
+ `(%make-option :documentation ,(doc (car form))))
+ (t
+ (let (long-name short-name
+ arg-name arg-optional-p
+ tag negated-tag
+ doc)
+ (dolist (f form)
+ (cond ((and (or (not tag) (not negated-tag))
+ (or (keywordp f)
+ (and (consp f)
+ (member (car f) '(lambda function)))))
+ (if tag
+ (setf negated-tag f)
+ (setf tag f)))
+ ((and (not long-name)
+ (or (rationalp f)
+ (symbolp f)
+ (stringp f)))
+ (setf long-name (if (stringp f) f
+ (format nil "~(~A~)" f))))
+ ((and (not short-name)
+ (characterp f))
+ (setf short-name f))
+ ((and (not doc)
+ (docp f))
+ (setf doc (doc f)))
+ ((and (consp f) (symbolp (car f)))
+ (case (car f)
+ (:short-name (setf short-name (cadr f)))
+ (:long-name (setf long-name (cadr f)))
+ (:tag (setf tag (cadr f)))
+ (:negated-tag (setf negated-tag (cadr f)))
+ (:arg (setf arg-name (cadr f)))
+ (:opt-arg (setf arg-name (cadr f))
+ (setf arg-optional-p t))
+ (:doc (setf doc (doc (cdr f))))
+ (t (let ((handler (get (car f) 'opthandler)))
+ (unless handler
+ (error "No handler `~S' defined." (car f)))
+ (let* ((var (cadr f))
+ (arg (gensym))
+ (thunk `#'(lambda (,arg)
+ (,handler (locf ,var)
+ ,arg
+ ,@(cddr f)))))
+ (if tag
+ (setf negated-tag thunk)
+ (setf tag thunk)))))))
+ (t
+ (error "Unexpected thing ~S in option form." f))))
+ `(make-option ,long-name ,short-name ,arg-name
+ ,@(and arg-optional-p `(:arg-optional-p t))
+ ,@(and tag `(:tag ,tag))
+ ,@(and negated-tag `(:negated-tag ,negated-tag))
+ ,@(and doc `(:documentation ,doc))))))))
(defmacro options (&rest optlist)
"More convenient way of initializing options. The OPTLIST is a list of
-OPTFORMS. Each OPTFORM is either a banner string, or a list of
-items. Acceptable items are interpreted as follows:
-
- KEYWORD or FUNCTION
- If no TAG is set yet, then as a TAG; otherwise as the NEGATED-TAG.
-
- STRING (or SYMBOL or RATIONAL)
- If no LONG-NAME seen yet, then the LONG-NAME. For symbols and rationals,
- the item is converted to a string and squashed to lower-case.
-
- CHARACTER
- The SHORT-NAME.
-
- STRING or (STRING STUFF...)
- If no DOCUMENTATION set yet, then the DOCUMENTATION string. A string is
- used as-is; a list is considered to be a `format' string and its
- arguments. This is evaluated at standard evaluation time: the option
- structure returned contains a simple documentation string.
-
- (:ARG NAME)
- Set the ARG-NAME.
-
- (:OPT-ARG NAME)
- Set the ARG-NAME, and also set ARG-OPTIONAL-P.
-
- (HANDLER VAR ARGS...)
- If no TAG is set yet, attach the HANDLER to this option, giving it ARGS.
- Otherwise, set the NEGATED-TAG."
- `(list ,@(mapcar (lambda (form)
- (if (stringp form)
- `(%make-option :documentation ,form)
- (parse-option-form form)))
+ OPTFORMS. Each OPTFORM is one of the following:
+
+ STRING A banner to print.
+
+ SYMBOL or (SYMBOL STUFF...)
+ If SYMBOL is an optform macro, the result of invoking it.
+
+ (...) A full option-form. See below.
+
+ Full option-forms are a list of the following kinds of items.
+
+ (:short-name CHAR)
+ (:long-name STRING)
+ (:arg STRING)
+ (:tag TAG)
+ (:negated-tag TAG)
+ (:doc STRING)
+ Set the appropriate slot of the option to the given value.
+ The argument is evaluated.
+
+ (:doc FORMAT-CONTROL ARGUMENTS...)
+ As for (:doc (format nil FORMAT-CONTROL ARGUMENTS...)).
+
+ KEYWORD, (function ...), (lambda ...)
+ If no TAG is set yet, then as a TAG; otherwise as the
+ NEGATED-TAG.
+
+ STRING (or SYMBOL or RATIONAL)
+ If no LONG-NAME seen yet, then the LONG-NAME. For symbols
+ and rationals, the item is converted to a string and squashed
+ to lower-case.
+
+ CHARACTER If no SHORT-NAME, then the SHORT-NAME.
+
+ STRING or (STRING STUFF...)
+ If no DOCUMENTATION set yet, then the DOCUMENTATION string,
+ as for (:doc STRING STUFF...)
+
+ (:opt-arg NAME)
+ Set the ARG-NAME, and also set ARG-OPTIONAL-P.
+
+ (HANDLER VAR ARGS...)
+ If no TAG is set yet, attach the HANDLER to this option,
+ giving it ARGS. Otherwise, set the NEGATED-TAG."
+
+ `(list ,@(mapcan (lambda (form)
+ (multiple-value-bind
+ (sym args)
+ (cond ((symbolp form) (values form nil))
+ ((and (consp form) (symbolp (car form)))
+ (values (car form) (cdr form)))
+ (t (values nil nil)))
+ (let ((macro (and sym (get sym 'optmacro))))
+ (if macro
+ (apply macro args)
+ (list (parse-option-form form))))))
optlist)))
;;;--------------------------------------------------------------------------
-;;; Support stuff for help and usage messages
+;;; Support stuff for help and usage messages.
(defun print-text (string
&optional
(start 0)
(end nil))
"Prints STRING to a pretty-printed STREAM, breaking it at whitespace and
-newlines in the obvious way. Stuff between square brackets is not broken:
-this makes usage messages work better."
+ newlines in the obvious way. Stuff between square brackets is not broken:
+ this makes usage messages work better."
(let ((i start)
(nest 0)
(splitp nil))
(flet ((emit ()
(write-string string stream :start start :end i)
(setf start i)))
- (unless end
- (setf end (length string)))
+ (setf-default end (length string))
(loop
(unless (< i end)
(emit)
(defun simple-usage (opts &optional mandatory-args)
"Build a simple usage list from a list of options, and (optionally)
-mandatory argument names."
+ mandatory argument names."
(let (short-simple long-simple short-arg long-arg)
(dolist (o opts)
(cond ((not (and (opt-documentation o)
(listify mandatory-args)))))
(defun show-usage (prog usage &optional (stream *standard-output*))
- "Basic usage-showing function. PROG is the program name, probable from
-*command-line-strings*. USAGE is a list of possible usages of the program,
-each of which is a list of items to be supplied by the user. In simple
-cases, a single string is sufficient."
+ "Basic usage-showing function. PROG is the program name, probably from
+ *command-line-strings*. USAGE is a list of possible usages of the
+ program, each of which is a list of items to be supplied by the user. In
+ simple cases, a single string is sufficient."
(pprint-logical-block (stream nil :prefix "Usage: ")
(dolist (u (listify usage))
(pprint-logical-block (stream nil :prefix (format nil "~A " prog))
(format stream "~{~A ~:_~}" (listify u)))
(pprint-newline :mandatory stream))))
-(defun show-help (prog ver usage opts &optional (stream *standard-output*))
- "Basic help-showing function. PROG is the program name, probably from
-*command-line-strings*. VER is the program's version number. USAGE is a
-list of the possible usages of the program, each of which may be a list of
-items to be supplied. OPTS is the list of supported options, as provided to
-the options parser. STREAM is the stream to write on."
- (format stream "~A, version ~A~2%" prog ver)
- (show-usage prog usage stream)
- (terpri stream)
+(defun show-options-help (opts &optional (stream *standard-output*))
+ "Write help for OPTS to the STREAM. This is the core of the `show-help'
+ function."
(let (newlinep)
(dolist (o opts)
(let ((doc (opt-documentation o)))
(print-text doc stream))
(terpri stream)))))))
+(defun show-help (prog ver usage opts &optional (stream *standard-output*))
+ "Basic help-showing function. PROG is the program name, probably from
+ *command-line-strings*. VER is the program's version number. USAGE is a
+ list of the possible usages of the program, each of which may be a list of
+ items to be supplied. OPTS is the list of supported options, as provided
+ to the options parser. STREAM is the stream to write on."
+ (format stream "~A, version ~A~2%" prog ver)
+ (show-usage prog usage stream)
+ (terpri stream)
+ (show-options-help opts stream))
+
(defun sanity-check-option-list (opts)
"Check the option list OPTS for basic sanity. Reused short and long option
-names are diagnosed. Maybe other problems will be reported later. Returns a
-list of warning strings."
+ names are diagnosed. Maybe other problems will be reported later.
+ Returns a list of warning strings."
(let ((problems nil)
(longs (make-hash-table :test #'equal))
(shorts (make-hash-table)))
shorts)
problems)))
+;;;--------------------------------------------------------------------------
+;;; Full program descriptions.
+
+(defvar *help* nil)
+(defvar *version* "<unreleased>")
+(defvar *usage* nil)
+
+(defun do-usage (&optional (stream *standard-output*))
+ (show-usage *program-name* *usage* stream))
+
+(defun die-usage ()
+ (do-usage *error-output*)
+ (exit 1))
+
+(defun opt-help (arg)
+ (declare (ignore arg))
+ (show-help *program-name* *version* *usage* *options*)
+ (typecase *help*
+ (string (terpri) (write-string *help*))
+ (null nil)
+ ((or function symbol) (terpri) (funcall *help*)))
+ (format t "~&")
+ (exit 0))
+(defun opt-version (arg)
+ (declare (ignore arg))
+ (format t "~A, version ~A~%" *program-name* *version*)
+ (exit 0))
+(defun opt-usage (arg)
+ (declare (ignore arg))
+ (do-usage)
+ (exit 0))
+
+(defoptmacro help-options (&key (short-help #\h)
+ (short-version #\v)
+ (short-usage #\u))
+ "Inserts a standard help options collection in an options list."
+ (flet ((shortform (char)
+ (and char (list char))))
+ (mapcar
+ #'parse-option-form
+ `("Help options"
+ (,@(shortform short-help) "help" #'opt-help
+ "Show this help message.")
+ (,@(shortform short-version) "version" #'opt-version
+ ("Show ~A's version number." *program-name*))
+ (,@(shortform short-usage) "usage" #'opt-usage
+ ("Show a very brief usage summary for ~A." *program-name*))))))
+
+(defun define-program (&key
+ (program-name nil progp)
+ (help nil helpp)
+ (version nil versionp)
+ (usage nil usagep)
+ (full-usage nil fullp)
+ (options nil optsp))
+ "Sets up all the required things a program needs to have to parse options
+ and respond to them properly."
+ (when progp (setf *program-name* program-name))
+ (when helpp (setf *help* help))
+ (when versionp (setf *version* version))
+ (when optsp (setf *options* options))
+ (cond ((and usagep fullp) (error "conflicting options"))
+ (usagep (setf *usage* (simple-usage *options* usage)))
+ (fullp (setf *usage* full-usage))))
+
+(defmacro do-options ((&key (parser '(make-option-parser)))
+ &body clauses)
+ "Handy all-in-one options parser macro. PARSER defaults to a new options
+ parser using the preset default options structure. The CLAUSES are
+ `case2'-like clauses to match options, and must be exhaustive. If there
+ is a clause (nil (REST) FORMS...) then the FORMS are evaluated after
+ parsing is done with REST bound to the remaining command-line arguments."
+ (let*/gensyms (parser)
+ `(progn
+ (loop
+ (,(if (find t clauses :key #'car) 'case2 'ecase2)
+ (option-parse-next ,parser)
+ ((nil) () (return))
+ ,@(remove-if #'null clauses :key #'car)))
+ ,@(let ((tail (find nil clauses :key #'car)))
+ (and tail
+ (destructuring-bind ((&optional arg) &rest forms) (cdr tail)
+ (if arg
+ (list `(let ((,arg (option-parse-remainder ,parser)))
+ ,@forms))
+ forms)))))))
+
;;;----- That's all, folks --------------------------------------------------
~mdw / lisp / blobdiff