;;; -*-lisp-*-
;;;
-;;; $Id$
-;;;
;;; Option parser, standard issue
;;;
;;; (c) 2005 Straylight/Edgeware
;;; 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.
;;; Packages.
(defpackage #:optparse
- (:use #:common-lisp #:mdw.base #:mdw.sys-base #:mdw.str)
- (:export #:exit #:*program-name* #:*command-line-strings*
- #:moan #:die
- #:option #:optionp #:make-option
- #:opt-short-name #:opt-long-name #:opt-tag #:opt-negated-tag
- #:opt-arg-name #:opt-arg-optional-p #:opt-documentation
- #:option-parser #:make-option-parser #:option-parser-p
- #:op-options #:op-non-option #:op-long-only-p #:op-numeric-p
- #:op-negated-numeric-p #:op-negated-p
- #:option-parse-error
- #:option-parse-remainder #:option-parse-next #:option-parse-try
- #:with-unix-error-reporting
- #: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
- #:*help* #:*version* #:*usage* #:*options*
- #:do-options #:help-opts #:define-program #:do-usage #:die-usage))
+ (:use #:common-lisp #:mdw.base #:mdw.sys-base))
(in-package #:optparse)
+;; Re-export symbols from sys-base.
+(export '(exit *program-name* *command-line*))
+
;;;--------------------------------------------------------------------------
;;; Standard error-reporting functions.
+(export 'moan)
(defun moan (msg &rest args)
"Report an error message in the usual way."
(format *error-output* "~&~A: ~?~%" *program-name* msg args))
+(export 'die)
(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
- (lambda (o s k)
- (declare (ignore k))
- (format s
- "#<option~@[ -~C,~]~@[ --~A~]~:[~2*~;~:[=~A~;[=~A]~]~]~@[ ~S~]>"
- (opt-short-name o)
- (opt-long-name o)
- (opt-arg-name o)
- (opt-arg-optional-p o)
- (opt-arg-name o)
- (opt-documentation o))))
- (:constructor %make-option)
- (:constructor make-option
- (long-name
- short-name
- &optional
- arg-name
- &key
- (tag (intern (string-upcase long-name)
- :keyword))
- negated-tag
- arg-optional-p
- doc
- (documentation doc))))
+(export '*options*)
+(defvar *options* nil)
+
+(export '(option optionp make-option
+ opt-short-name opt-long-name opt-tag opt-negated-tag
+ opt-arg-name opt-arg-optional-p opt-documentation))
+(defstruct (option
+ (:predicate optionp)
+ (:conc-name opt-)
+ (:print-function
+ (lambda (o s k)
+ (declare (ignore k))
+ (print-unreadable-object (o s :type t)
+ (format s "~@[-~C, ~]~@[--~A~]~
+ ~*~@[~2:*~:[=~A~;[=~A]~]~]~
+ ~@[ ~S~]"
+ (opt-short-name o)
+ (opt-long-name o)
+ (opt-arg-optional-p o)
+ (opt-arg-name o)
+ (opt-documentation o)))))
+ (:constructor %make-option)
+ (:constructor make-option
+ (long-name short-name
+ &optional arg-name
+ &key (tag (intern (string-upcase long-name) :keyword))
+ negated-tag
+ arg-optional-p
+ doc (documentation doc))))
"Describes a command-line option. Slots:
LONG-NAME The option's long name. If this is null, the `option' is
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.
SHORT-NAME The option's short name. This must be a single character, or
nil if the option has no short name.
text.
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)
- (short-name nil :type (or null character))
- (arg-name nil :type (or null string))
- (arg-optional-p nil :type t)
- (documentation nil :type (or null string)))
-
-(defstruct (option-parser (:conc-name op-)
- (:constructor make-option-parser
- (&key
- ((:args argstmp)
- (cdr *command-line-strings*))
- (options *options*)
- (non-option :skip)
- ((:numericp numeric-p))
- negated-numeric-p
- long-only-p
- &aux
- (args (cons nil argstmp))
- (next args)
- (negated-p (or negated-numeric-p
- (some
- #'opt-negated-tag
- options))))))
+ (long-name nil :type (or null string) :read-only t)
+ (tag nil :type t :read-only t)
+ (negated-tag nil :type t :read-only t)
+ (short-name nil :type (or null character) :read-only t)
+ (arg-name nil :type (or null string) :read-only t)
+ (arg-optional-p nil :type t :read-only t)
+ (documentation nil :type (or null string)) :read-only t)
+
+(export '(option-parser option-parser-p make-option-parser
+ op-options op-non-option op-long-only-p
+ op-numeric-p op-negated-numeric-p op-negated-p))
+(defstruct (option-parser
+ (:conc-name op-)
+ (:constructor make-option-parser
+ (&key ((:args argstmp) (cdr *command-line*))
+ (options *options*)
+ (non-option :skip)
+ ((:numericp numeric-p))
+ negated-numeric-p
+ long-only-p
+ &aux (args (cons nil argstmp))
+ (next args)
+ (negated-p (or negated-numeric-p
+ (some #'opt-negated-tag
+ options))))))
"An option parser object. Slots:
ARGS The arguments to be parsed. Usually this will be
- *command-line-strings*.
+ *command-line*.
OPTIONS List of option structures describing the acceptable options.
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)))
+ (options nil :type list :read-only t)
+ (non-option :skip :type (or function (member :skip :stop :return))
+ :read-only t)
(next nil :type list)
(short-opt nil :type (or null string))
(short-opt-index 0 :type fixnum)
(short-opt-neg-p nil :type t)
- (long-only-p nil :type t)
- (numeric-p nil :type t)
- (negated-numeric-p nil :type t)
- (negated-p nil :type t))
+ (long-only-p nil :type t :read-only t)
+ (numeric-p nil :type t :read-only t)
+ (negated-numeric-p nil :type t :read-only t)
+ (negated-p nil :type t) :read-only t)
+(export 'option-parse-error)
(define-condition option-parse-error (error simple-condition)
()
(:documentation
:format-control msg
:format-arguments args)))
+(export 'option-parse-remainder)
(defun option-parse-remainder (op)
"Returns the unparsed remainder of the command line."
(cdr (op-args op)))
+(export 'option-parse-return)
+(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)))
+
+(export 'option-parse-next)
(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
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.)
+ 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."
- (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))
+ (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
+ #.(concatenate 'string
+ "Ambiguous long option `~A' -- "
+ "could be any of:"
+ "~{~%~8T--~A~}")
+ 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
- (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)))))))))))))
+ (setf (op-short-opt op) arg
+ (op-short-opt-index op) 1
+ (op-short-opt-neg-p op) negp))))))))))))))
+(export 'option-parse-try)
(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
(setf ,retcode nil)))
,retcode)))
+(export 'with-unix-error-reporting)
(defmacro with-unix-error-reporting ((&key) &body body)
"Evaluate BODY with errors reported in the standard Unix fashion."
(with-gensyms (cond)
(progn ,@body)
(simple-condition (,cond)
(apply #'die
- (simple-condition-format-control ,cond)
- (simple-condition-format-arguments ,cond)))
+ (simple-condition-format-control ,cond)
+ (simple-condition-format-arguments ,cond)))
(error (,cond)
(die "~A" ,cond)))))
;;;--------------------------------------------------------------------------
;;; Standard option handlers.
+(export 'defopthandler)
(defmacro defopthandler (name (var &optional (arg (gensym)))
(&rest args)
&body body)
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
+ (with-parsed-body (body decls docs) body
+ `(progn
+ (setf (get ',name 'opthandler) ',func)
+ (defun ,func (,var ,arg ,@args)
+ ,@docs ,@decls
(declare (ignorable ,arg))
- ,@body))
- ',name)))
+ (with-locatives ,var
+ ,@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
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)))
+ (setf-default end (length string))
(labels ((simple (i r goodp sgn)
(multiple-value-bind
(a i)
(t
(get-radix start radix +1)))))
+(export 'invoke-option-handler)
(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."
;;;--------------------------------------------------------------------------
;;; Built-in option handlers.
+(export 'set)
(defopthandler set (var) (&optional (value t))
"Sets VAR to VALUE; defaults to t."
(setf var value))
+(export 'clear)
(defopthandler clear (var) (&optional (value nil))
"Sets VAR to VALUE; defaults to nil."
(setf var value))
+(export 'inc)
(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."
(when (>= var max)
(setf var max)))
+(export 'dec)
(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."
(when (<= var min)
(setf var min)))
+(export 'read)
(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 (cond)
(option-parse-error (format nil "~A" cond)))))
+(export 'int)
(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
(when (or (and min (< v min))
(and max (> v max)))
(option-parse-error
- "Integer ~A out of range (must have ~@[~D <= ~]x~@[ <= ~D~])"
+ #.(concatenate 'string
+ "Integer ~A out of range "
+ "(must have ~@[~D <= ~]x~@[ <= ~D~])")
arg min max))
(setf var v)))
+(export 'string)
(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))))))
-
+(export 'keyword)
+(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 #.(concatenate 'string
+ "Argument `~A' invalid: "
+ "must be one of:"
+ "~{~%~8T~(~A~)~}")
+ arg valid))
+ ((null (cdr matches))
+ (setf var (car matches)))
+ (t
+ (option-parse-error #.(concatenate 'string
+ "Argument `~A' ambiguous: "
+ "may be any of:"
+ "~{~%~8T~(~A~)~}")
+ arg matches)))))))
+
+(export 'list)
(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'."
;;;--------------------------------------------------------------------------
;;; Option descriptions.
+(export 'defoptmacro)
(defmacro defoptmacro (name args &body body)
"Defines an option macro NAME. Option macros should produce a list of
expressions producing one option structure each."
(setf (get ',name 'optmacro) (lambda ,args ,@body))
',name))
+(export 'parse-option-form)
(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."
(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))
(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))))))))
+ ,@(and arg-optional-p `(:arg-optional-p t))
+ ,@(and tag `(:tag ,tag))
+ ,@(and negated-tag `(:negated-tag ,negated-tag))
+ ,@(and doc `(:documentation ,doc))))))))
+(export 'options)
(defmacro options (&rest optlist)
"More convenient way of initializing options. The OPTLIST is a list of
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.
+ If SYMBOL is an optform macro, the result of invoking it.
(...) A full option-form. See below.
- Full option-forms are as follows.
+ Full option-forms are a list of the following kinds of items.
- KEYWORD or FUNCTION
+ (: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.
and rationals, the item is converted to a string and squashed
to lower-case.
- CHARACTER The SHORT-NAME.
+ 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...)
-
- (: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...).
+ as for (:doc STRING STUFF...)
- (:ARG NAME) Set the ARG-NAME.
-
- (:OPT-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)
(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)
(#\] (when (plusp nest) (decf nest))))))
(incf i))))))
+(export 'simple-usage)
(defun simple-usage (opts &optional mandatory-args)
"Build a simple usage list from a list of options, and (optionally)
mandatory argument names."
:key #'opt-long-name)))
(listify mandatory-args)))))
+(export 'show-usage)
(defun show-usage (prog usage &optional (stream *standard-output*))
"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."
+ *command-line*. 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))
+ (pprint-logical-block (stream nil
+ :prefix (concatenate 'string 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)))
(t
(setf newlinep t)
(pprint-logical-block (stream nil :prefix " ")
- (pprint-indent :block 30 stream)
(format stream "~:[ ~;-~:*~C,~] --~A"
(opt-short-name o)
(opt-long-name o))
(opt-arg-name o)))
(write-string " " stream)
(pprint-tab :line 30 1 stream)
+ (pprint-indent :block 30 stream)
(print-text doc stream))
(terpri stream)))))))
+(export 'show-help)
+(defun show-help (prog ver usage opts &optional (stream *standard-output*))
+ "Basic help-showing function. PROG is the program name, probably from
+ *command-line*. 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))
+
+(export 'sanity-check-options-list)
(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.
;;;--------------------------------------------------------------------------
;;; Full program descriptions.
-(defvar *help*)
-(defvar *version*)
-(defvar *usage*)
+(export '(*help* *version* *usage))
+(defvar *help* nil)
+(defvar *version* "<unreleased>")
+(defvar *usage* nil)
+
+(export 'do-usage)
+(defun do-usage (&optional (stream *standard-output*))
+ (show-usage *program-name* *usage* stream))
+
+(export 'die-usage)
+(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 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*)))))
-
+(export 'help-options)
+(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*))))))
+
+(export 'define-program)
(defun define-program (&key
- program-name
- help
- version
- usage full-usage
- options)
+ (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 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)
+ (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))))
+
+(export 'do-options)
+(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))
+ (let*/gensyms (parser)
+ `(progn
(loop
(,(if (find t clauses :key #'car) 'case2 'ecase2)
- (option-parse-next ,tparser)
+ (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 ,tparser)))
- ,@forms))
+ (list `(let ((,arg (option-parse-remainder ,parser)))
+ ,@forms))
forms)))))))
;;;----- That's all, folks --------------------------------------------------
~mdw / lisp / blobdiff