#: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 #: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*)
+
(defstruct (option (:predicate optionp)
(:conc-name opt-)
(:print-function
(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
`(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)))))
(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
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."
(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."
(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
(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
"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'."
(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."
(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:
+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.
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.
+ 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.
(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)))
+ `(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
(listify mandatory-args)))))
(defun show-usage (prog usage &optional (stream *standard-output*))
- "Basic usage-showing function. PROG is the program name, probable from
+ "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."
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)
+ (with-gensyms (topt targ tparser)
+ (flet ((frob (clause)
+ (destructuring-bind
+ (case (&optional arg) &rest forms)
+ clause
+ (and case
+ (list `(,case ,@(if arg
+ `(let ((,arg ,targ)) ,@forms)
+ forms)))))))
+ `(let ((,tparser ,parser))
+ (loop
+ (multiple-value-bind (,topt ,targ) (option-parse-next ,tparser)
+ (declare (ignorable ,targ))
+ (unless ,topt (return))
+ (case ,topt
+ ,@(mapcan #'frob clauses))))
+ ,@(let ((tail (find nil clauses :key #'car)))
+ (and tail
+ (destructuring-bind
+ ((&optional arg) &rest forms)
+ (cdr tail)
+ (list (if arg
+ `(let ((,arg (option-parse-remainder
+ ,tparser)))
+ ,@forms)
+ forms)))))))))
+
;;;----- That's all, folks --------------------------------------------------
~mdw / lisp / commitdiff