X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/lisp/blobdiff_plain/0ff9df03bb54ba792cefa551face51748ae34259..003ebbaa2cf2a7bb71c65c35a8703b38508dea8d:/optparse.lisp diff --git a/optparse.lisp b/optparse.lisp index acbe11f..1322e10 100644 --- a/optparse.lisp +++ b/optparse.lisp @@ -13,12 +13,12 @@ ;;; 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. @@ -28,7 +28,7 @@ (defpackage #:optparse (:use #:common-lisp #:mdw.base #:mdw.sys-base #:mdw.str) - (:export #:exit #:*program-name* #:*command-line-strings* + (:export #:exit #:*program-name* #:*command-line* #:moan #:die #:option #:optionp #:make-option #:opt-short-name #:opt-long-name #:opt-tag #:opt-negated-tag @@ -38,7 +38,7 @@ (defpackage #:optparse #: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 @@ -46,7 +46,8 @@ (defpackage #:optparse #: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)) + #:do-options #:help-options + #:define-program #:do-usage #:die-usage)) (in-package #:optparse) @@ -65,7 +66,7 @@ (defun die (&rest args) ;;;-------------------------------------------------------------------------- ;;; The main option parser. -(defvar *options*) +(defvar *options* nil) (defstruct (option (:predicate optionp) (:conc-name opt-) @@ -73,7 +74,13 @@ (defstruct (option (:predicate optionp) (lambda (o s k) (declare (ignore k)) (format s - "#" + #.(concatenate 'string + "#") (opt-short-name o) (opt-long-name o) (opt-arg-name o) @@ -104,7 +111,7 @@ (defstruct (option (:predicate optionp) 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. @@ -135,7 +142,7 @@ (defstruct (option-parser (:conc-name op-) (:constructor make-option-parser (&key ((:args argstmp) - (cdr *command-line-strings*)) + (cdr *command-line*)) (options *options*) (non-option :skip) ((:numericp numeric-p)) @@ -151,7 +158,7 @@ (defstruct (option-parser (:conc-name op-) "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. @@ -204,6 +211,12 @@ (defun option-parse-remainder (op) "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 @@ -214,185 +227,188 @@ (defun option-parse-next (op) 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)))))))))))))) (defmacro option-parse-try (&body body) "Report errors encountered while parsing options, and continue struggling @@ -438,13 +454,15 @@ (defmacro defopthandler (name (var &optional (arg (gensym))) 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 @@ -454,7 +472,7 @@ (defun parse-c-integer (string &key radix (start 0) end) 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) @@ -555,7 +573,9 @@ (defopthandler int (var arg) (&key radix min max) (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))) @@ -563,29 +583,42 @@ (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 #.(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))))))) (defopthandler list (var arg) (&optional handler &rest handler-args) "Collect ARGs in a list at VAR. ARGs are translated by the HANDLER first, @@ -648,6 +681,10 @@ (compile-time-defun parse-option-form (form) (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)) @@ -679,13 +716,25 @@ (defmacro options (&rest optlist) 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. + + (: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 or FUNCTION + KEYWORD, (function ...), (lambda ...) If no TAG is set yet, then as a TAG; otherwise as the NEGATED-TAG. @@ -694,25 +743,19 @@ (defmacro options (&rest optlist) 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...) + 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) + (: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) @@ -744,8 +787,7 @@ (defun print-text (string (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) @@ -812,24 +854,19 @@ (defun simple-usage (opts &optional mandatory-args) (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))) @@ -844,7 +881,6 @@ (defun show-help (prog ver usage opts &optional (stream *standard-output*)) (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)) @@ -854,9 +890,21 @@ (defun show-help (prog ver usage opts &optional (stream *standard-output*)) (opt-arg-name o))) (write-string " " stream) (pprint-tab :line 30 1 stream) + (pprint-indent :block 30 stream) (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*. 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. @@ -882,89 +930,88 @@ (defun sanity-check-option-list (opts) ;;;-------------------------------------------------------------------------- ;;; Full program descriptions. -(defvar *help*) -(defvar *version*) -(defvar *usage*) +(defvar *help* nil) +(defvar *version* "") +(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 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*))))) +(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 - 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)))) + +(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 --------------------------------------------------