;;; along with this program; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-(defpackage #:mdw.optparse
+;;;--------------------------------------------------------------------------
+;;; Packages.
+
+(defpackage #:optparse
(:use #:common-lisp #:mdw.base #:mdw.sys-base #:mdw.str)
(:export #:exit #:*program-name* #:*command-line-strings*
#:moan #:die
#: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-opts #:define-program #:do-usage #:die-usage))
-(in-package #:mdw.optparse)
+(in-package #:optparse)
+;;;--------------------------------------------------------------------------
;;; Standard error-reporting functions.
(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)
(exit 1))
+;;;--------------------------------------------------------------------------
;;; The main option parser.
+(defvar *options*)
+
(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."
(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."
+ 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)))
(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)))))
+;;;--------------------------------------------------------------------------
;;; Standard option handlers.
(defmacro defopthandler (name (var &optional (arg (gensym)))
(&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)
(with-locatives ,var
(declare (ignorable ,arg))
,@body))
- ',name)))
+ ',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."
+ 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)))
(labels ((simple (i r goodp sgn)
(multiple-value-bind
(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))
(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)
+ (: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 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,
+ as for (:DOC STRING STUFF...)
+
+ (:DOC STRING STUFF...)
+ The DOCUMENATION string. With no STUFF, STRING is used as
+ is;otherwise the documentation string is computed by (format
+ nil STRING STUFF...).
+
+ (: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 ,@(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))
(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))
(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."
+ *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 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*)
+(defvar *version*)
+(defvar *usage*)
+
+(defun opt-help (arg)
+ (declare (ignore arg))
+ (show-help *program-name* *version* *usage* *options*)
+ (typecase *help*
+ (string (terpri) (write-string *help*))
+ ((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 do-usage (&optional (stream *standard-output*))
+ (show-usage *program-name* *usage* stream))
+
+(defun die-usage ()
+ (do-usage *error-output*)
+ (exit 1))
+
+(defun opt-usage (arg)
+ (declare (ignore arg))
+ (do-usage)
+ (exit 0))
+
+(defoptmacro help-opts (&key (short-help #\h)
+ (short-version #\v)
+ (short-usage #\u))
+ (mapcar #'parse-option-form
+ `("Help options"
+ (,@(and short-help (list short-help))
+ "help"
+ #'opt-help
+ "Show this help message.")
+ (,@(and short-version (list short-version))
+ "version"
+ #'opt-version
+ ("Show ~A's version number." *program-name*))
+ (,@(and short-usage (list short-usage))
+ "usage"
+ #'opt-usage
+ ("Show a very brief usage summary for ~A." *program-name*)))))
+
+(defun define-program (&key
+ program-name
+ help
+ version
+ usage full-usage
+ options)
+ "Sets up all the required things a program needs to have to parse options
+ and respond to them properly."
+ (when program-name (setf *program-name* program-name))
+ (when help (setf *help* help))
+ (when version (setf *version* version))
+ (when options (setf *options* options))
+ (cond ((and usage full-usage) (error "conflicting options"))
+ (usage (setf *usage* (simple-usage *options* usage)))
+ (full-usage (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."
+ (with-gensyms (tparser)
+ `(let ((,tparser ,parser))
+ (loop
+ (,(if (find t clauses :key #'car) 'case2 'ecase2)
+ (option-parse-next ,tparser)
+ ((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 ,tparser)))
+ ,@forms))
+ forms)))))))
+
;;;----- That's all, folks --------------------------------------------------
~mdw / lisp / blobdiff