X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/lisp/blobdiff_plain/202c91a3c5682b65cd3681bb5bdb919ae6b13c85..003ebbaa2cf2a7bb71c65c35a8703b38508dea8d:/optparse.lisp diff --git a/optparse.lisp b/optparse.lisp index 7819b70..1322e10 100644 --- a/optparse.lisp +++ b/optparse.lisp @@ -13,19 +13,22 @@ ;;; 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. -(defpackage #:mdw.optparse +;;;-------------------------------------------------------------------------- +;;; Packages. + +(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 @@ -35,35 +38,49 @@ (defpackage #:mdw.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 #:parse-option-form #:options #:simple-usage #:show-usage #:show-version #:show-help - #:sanity-check-option-list)) + #:sanity-check-option-list + #:*help* #:*version* #:*usage* #:*options* + #:do-options #:help-options + #:define-program #:do-usage #:die-usage)) -(in-package #: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* nil) + (defstruct (option (:predicate optionp) (:conc-name opt-) (:print-function (lambda (o s k) (declare (ignore k)) (format s - "#" + #.(concatenate 'string + "#") (opt-short-name o) (opt-long-name o) (opt-arg-name o) @@ -85,32 +102,34 @@ (defstruct (option (:predicate optionp) (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) @@ -121,9 +140,10 @@ (defstruct (option (:predicate optionp) (defstruct (option-parser (:conc-name op-) (:constructor make-option-parser - (argstmp - options - &key + (&key + ((:args argstmp) + (cdr *command-line*)) + (options *options*) (non-option :skip) ((:numericp numeric-p)) negated-numeric-p @@ -137,32 +157,32 @@ (defstruct (option-parser (:conc-name op-) 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*. -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))) @@ -177,8 +197,9 @@ (defstruct (option-parser (:conc-name op-) (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." @@ -190,199 +211,209 @@ (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 tag -of the next option read, and ARG is the argument attached to it, or nil if -there was no argument. If there are no more options, returns nil twice. -Options whose TAG is a function aren't returned; instead, the tag function is -called, with the option argument (or nil) as the only argument. It is safe -for tag functions to throw out of option-parse-next, if they desparately need -to. (This is the only way to actually get option-parse-next to return a -function value, should that be what you want.) - -While option-parse-next is running, there is a restart `skip-option' which -moves on to the next option. Error handlers should use this to resume after -parsing errors." - (loop - (labels ((ret (opt &optional arg) - (return-from option-parse-next (values opt arg))) - (finished () - (setf (op-next op) nil) - (ret nil nil)) - (peek-arg () - (cadr (op-next op))) - (more-args-p () - (and (op-next op) - (cdr (op-next op)))) - (skip-arg () - (setf (op-next op) (cdr (op-next op)))) - (eat-arg () - (setf (cdr (op-next op)) (cddr (op-next op)))) - (get-arg () - (prog1 (peek-arg) (eat-arg))) - (process-option (o name negp &key arg argfunc) - (cond ((not (opt-arg-name o)) - (when arg - (option-parse-error - "Option `~A' does not accept arguments" - name))) - (arg) - (argfunc - (setf arg (funcall argfunc))) - ((opt-arg-optional-p o)) - ((more-args-p) - (setf arg (get-arg))) - (t - (option-parse-error "Option `~A' requires an argument" - name))) - (let ((how (if negp (opt-negated-tag o) (opt-tag o)))) - (if (functionp how) - (funcall how arg) - (ret how arg)))) - (process-long-option (arg start negp) - (when (and (not negp) - (op-negated-p op) - (> (length arg) (+ start 3)) - (string= arg "no-" - :start1 start :end1 (+ start 3))) - (incf start 3) - (setf negp t)) - (let* ((matches nil) - (eqpos (position #\= arg :start start)) - (len (or eqpos (length arg))) - (optname (subseq arg 0 len)) - (len-2 (- len start))) - (dolist (o (op-options op)) - (cond ((or (not (stringp (opt-long-name o))) - (and negp (not (opt-negated-tag o))) - (< (length (opt-long-name o)) len-2) - (string/= optname (opt-long-name o) - :start1 start :end2 len-2))) - ((= (length (opt-long-name o)) len-2) - (setf matches (list o)) - (return)) + initialized appropriately. Returns two values, OPT and ARG: OPT is the + tag of the next option read, and ARG is the argument attached to it, or + nil if there was no argument. If there are no more options, returns nil + twice. Options whose TAG is a function aren't returned; instead, the tag + function is called, with the option argument (or nil) as the only + argument. It is safe for tag functions to throw out of option-parse-next, + if they desparately need to. (This is the only way to actually get + option-parse-next to return a function value, should that be what you + want. See `option-parse-return' for a way of doing this.) + + While option-parse-next is running, there is a restart `skip-option' which + moves on to the next option. Error handlers should use this to resume + after parsing errors." + (labels ((ret (opt &optional arg) + (return-from option-parse-next (values opt arg))) + (finished () + (setf (op-next op) nil) + (ret nil nil)) + (peek-arg () + (cadr (op-next op))) + (more-args-p () + (and (op-next op) + (cdr (op-next op)))) + (skip-arg () + (setf (op-next op) (cdr (op-next op)))) + (eat-arg () + (setf (cdr (op-next op)) (cddr (op-next op)))) + (get-arg () + (prog1 (peek-arg) (eat-arg))) + (process-option (o name negp &key arg argfunc) + (cond ((not (opt-arg-name o)) + (when arg + (option-parse-error + "Option `~A' does not accept arguments" + name))) + (arg) + (argfunc + (setf arg (funcall argfunc))) + ((opt-arg-optional-p o)) + ((more-args-p) + (setf arg (get-arg))) + (t + (option-parse-error "Option `~A' requires an argument" + name))) + (let ((how (if negp (opt-negated-tag o) (opt-tag o)))) + (if (functionp how) + (funcall how arg) + (ret how arg)))) + (process-long-option (arg start negp) + (when (and (not negp) + (op-negated-p op) + (> (length arg) (+ start 3)) + (string= arg "no-" + :start1 start :end1 (+ start 3))) + (incf start 3) + (setf negp t)) + (let* ((matches nil) + (eqpos (position #\= arg :start start)) + (len (or eqpos (length arg))) + (optname (subseq arg 0 len)) + (len-2 (- len start))) + (dolist (o (op-options op)) + (cond ((or (not (stringp (opt-long-name o))) + (and negp (not (opt-negated-tag o))) + (< (length (opt-long-name o)) len-2) + (string/= optname (opt-long-name o) + :start1 start :end2 len-2))) + ((= (length (opt-long-name o)) len-2) + (setf matches (list o)) + (return)) + (t + (push o matches)))) + (cond ((null matches) + (option-parse-error "Unknown option `~A'" optname)) + ((cdr matches) + (option-parse-error + #.(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 -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 @@ -406,36 +437,42 @@ (defmacro with-unix-error-reporting ((&key) &body body) `(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) - (defun ,func (,var ,arg ,@args) - (with-locatives ,var - (declare (ignorable ,arg)) - ,@body)) - ',name))) + (with-parsed-body (body decls docs) body + `(progn + (setf (get ',name 'opthandler) ',func) + (defun ,func (,var ,arg ,@args) + ,@docs ,@decls + (with-locatives ,var + (declare (ignorable ,arg)) + ,@body)) + ',name)))) (defun parse-c-integer (string &key radix (start 0) end) "Parse STRING, or at least the parts of it between START and END, according -to the standard C rules. Well, almost: the 0 and 0x prefixes are accepted, -but so too are 0o (Haskell) and 0b (original); also RADIX_DIGITS is accepted, -for any radix between 2 and 36. Prefixes are only accepted if RADIX is nil. -Returns two values: the integer parsed (or nil if there wasn't enough for a -sensible parse), and the index following the characters of the integer." - (unless end (setf end (length string))) + to the standard C rules. Well, almost: the 0 and 0x prefixes are + accepted, but so too are 0o (Haskell) and 0b (original); also RADIX_DIGITS + is accepted, for any radix between 2 and 36. Prefixes are only accepted + if RADIX is nil. Returns two values: the integer parsed (or nil if there + wasn't enough for a sensible parse), and the index following the + characters of the integer." + (setf-default end (length string)) (labels ((simple (i r goodp sgn) (multiple-value-bind (a i) @@ -478,35 +515,42 @@ (defun parse-c-integer (string &key radix (start 0) end) (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) @@ -515,57 +559,87 @@ (defopthandler read (var arg) () (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)) (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))) + (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, -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)) @@ -574,96 +648,129 @@ (compile-time-defun parse-option-form (form) (or (stringp form) (and (consp form) (stringp (car form)))))) - (if (and (docp (car form)) - (null (cdr form))) - `(%make-option :documentation ,(doc (car form))) - (let (long-name short-name - arg-name arg-optional-p - tag negated-tag - doc) - (dolist (f form) - (cond ((and (or (not tag) (not negated-tag)) - (or (keywordp f) - (and (consp f) - (member (car f) '(lambda function))))) - (if tag - (setf negated-tag f) - (setf tag f))) - ((and (not long-name) - (or (rationalp f) - (symbolp f) - (stringp f))) - (setf long-name (if (stringp f) f - (format nil "~(~A~)" f)))) - ((and (not short-name) - (characterp f)) - (setf short-name f)) - ((and (not doc) - (docp f)) - (setf doc (doc f))) - ((and (consp f) (symbolp (car f))) - (case (car f) - (:arg (setf arg-name (cadr f))) - (:opt-arg (setf arg-name (cadr f)) - (setf arg-optional-p t)) - (:doc (setf doc (doc (cdr f)))) - (t (let ((handler (get (car f) 'opthandler))) - (unless handler - (error "No handler `~S' defined." (car f))) - (let* ((var (cadr f)) - (arg (gensym)) - (thunk `#'(lambda (,arg) - (,handler (locf ,var) - ,arg - ,@(cddr f))))) - (if tag - (setf negated-tag thunk) - (setf tag thunk))))))) - (t - (error "Unexpected thing ~S in option form." f)))) - `(make-option ,long-name ,short-name ,arg-name - ,@(and arg-optional-p `(:arg-optional-p t)) - ,@(and tag `(:tag ,tag)) - ,@(and negated-tag `(:negated-tag ,negated-tag)) - ,@(and doc `(:documentation ,doc))))))) + (cond ((stringp form) + `(%make-option :documentation ,form)) + ((not (listp form)) + (error "option form must be string or list")) + ((and (docp (car form)) (null (cdr form))) + `(%make-option :documentation ,(doc (car form)))) + (t + (let (long-name short-name + arg-name arg-optional-p + tag negated-tag + doc) + (dolist (f form) + (cond ((and (or (not tag) (not negated-tag)) + (or (keywordp f) + (and (consp f) + (member (car f) '(lambda function))))) + (if tag + (setf negated-tag f) + (setf tag f))) + ((and (not long-name) + (or (rationalp f) + (symbolp f) + (stringp f))) + (setf long-name (if (stringp f) f + (format nil "~(~A~)" f)))) + ((and (not short-name) + (characterp f)) + (setf short-name f)) + ((and (not doc) + (docp f)) + (setf doc (doc f))) + ((and (consp f) (symbolp (car f))) + (case (car f) + (:short-name (setf short-name (cadr f))) + (:long-name (setf long-name (cadr f))) + (:tag (setf tag (cadr f))) + (:negated-tag (setf negated-tag (cadr f))) + (:arg (setf arg-name (cadr f))) + (:opt-arg (setf arg-name (cadr f)) + (setf arg-optional-p t)) + (:doc (setf doc (doc (cdr f)))) + (t (let ((handler (get (car f) 'opthandler))) + (unless handler + (error "No handler `~S' defined." (car f))) + (let* ((var (cadr f)) + (arg (gensym)) + (thunk `#'(lambda (,arg) + (,handler (locf ,var) + ,arg + ,@(cddr f))))) + (if tag + (setf negated-tag thunk) + (setf tag thunk))))))) + (t + (error "Unexpected thing ~S in option form." f)))) + `(make-option ,long-name ,short-name ,arg-name + ,@(and arg-optional-p `(:arg-optional-p t)) + ,@(and tag `(:tag ,tag)) + ,@(and negated-tag `(:negated-tag ,negated-tag)) + ,@(and doc `(:documentation ,doc)))))))) (defmacro options (&rest optlist) "More convenient way of initializing options. The OPTLIST is a list of -OPTFORMS. Each OPTFORM is either a banner string, or a list of -items. Acceptable items are interpreted as follows: - - KEYWORD or FUNCTION - If no TAG is set yet, then as a TAG; otherwise as the NEGATED-TAG. - - STRING (or SYMBOL or RATIONAL) - If no LONG-NAME seen yet, then the LONG-NAME. For symbols and rationals, - the item is converted to a string and squashed to lower-case. - - CHARACTER - The SHORT-NAME. - - STRING or (STRING STUFF...) - If no DOCUMENTATION set yet, then the DOCUMENTATION string. A string is - used as-is; a list is considered to be a `format' string and its - arguments. This is evaluated at standard evaluation time: the option - structure returned contains a simple documentation string. - - (:ARG NAME) - Set the ARG-NAME. - - (:OPT-ARG NAME) - Set the ARG-NAME, and also set ARG-OPTIONAL-P. - - (HANDLER VAR ARGS...) - If no TAG is set yet, attach the HANDLER to this option, giving it ARGS. - Otherwise, set the NEGATED-TAG." - `(list ,@(mapcar (lambda (form) - (if (stringp form) - `(%make-option :documentation ,form) - (parse-option-form form))) + OPTFORMS. Each OPTFORM is one of the following: + + STRING A banner to print. + + SYMBOL or (SYMBOL STUFF...) + If SYMBOL is an optform macro, the result of invoking it. + + (...) A full option-form. See below. + + Full option-forms are a list of the following kinds of items. + + (:short-name CHAR) + (:long-name STRING) + (:arg STRING) + (:tag TAG) + (:negated-tag TAG) + (:doc STRING) + Set the appropriate slot of the option to the given value. + The argument is evaluated. + + (:doc FORMAT-CONTROL ARGUMENTS...) + As for (:doc (format nil FORMAT-CONTROL ARGUMENTS...)). + + KEYWORD, (function ...), (lambda ...) + If no TAG is set yet, then as a TAG; otherwise as the + NEGATED-TAG. + + STRING (or SYMBOL or RATIONAL) + If no LONG-NAME seen yet, then the LONG-NAME. For symbols + and rationals, the item is converted to a string and squashed + to lower-case. + + CHARACTER If no SHORT-NAME, then the SHORT-NAME. + + STRING or (STRING STUFF...) + If no DOCUMENTATION set yet, then the DOCUMENTATION string, + as for (:doc STRING STUFF...) + + (:opt-arg NAME) + Set the ARG-NAME, and also set ARG-OPTIONAL-P. + + (HANDLER VAR ARGS...) + If no TAG is set yet, attach the HANDLER to this option, + giving it ARGS. Otherwise, set the NEGATED-TAG." + + `(list ,@(mapcan (lambda (form) + (multiple-value-bind + (sym args) + (cond ((symbolp form) (values form nil)) + ((and (consp form) (symbolp (car form))) + (values (car form) (cdr form))) + (t (values nil nil))) + (let ((macro (and sym (get sym 'optmacro)))) + (if macro + (apply macro args) + (list (parse-option-form form)))))) optlist))) -;;; Support stuff for help and usage messages +;;;-------------------------------------------------------------------------- +;;; Support stuff for help and usage messages. (defun print-text (string &optional @@ -672,16 +779,15 @@ (defun print-text (string (start 0) (end nil)) "Prints STRING to a pretty-printed STREAM, breaking it at whitespace and -newlines in the obvious way. Stuff between square brackets is not broken: -this makes usage messages work better." + newlines in the obvious way. Stuff between square brackets is not broken: + this makes usage messages work better." (let ((i start) (nest 0) (splitp nil)) (flet ((emit () (write-string string stream :start start :end i) (setf start i))) - (unless end - (setf end (length string))) + (setf-default end (length string)) (loop (unless (< i end) (emit) @@ -706,7 +812,7 @@ (defun print-text (string (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) @@ -747,25 +853,20 @@ (defun simple-usage (opts &optional mandatory-args) (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*. 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))) @@ -780,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)) @@ -790,13 +890,25 @@ (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. 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))) @@ -815,4 +927,91 @@ (defun sanity-check-option-list (opts) shorts) problems))) +;;;-------------------------------------------------------------------------- +;;; Full program descriptions. + +(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 opt-usage (arg) + (declare (ignore arg)) + (do-usage) + (exit 0)) + +(defoptmacro help-options (&key (short-help #\h) + (short-version #\v) + (short-usage #\u)) + "Inserts a standard help options collection in an options list." + (flet ((shortform (char) + (and char (list char)))) + (mapcar + #'parse-option-form + `("Help options" + (,@(shortform short-help) "help" #'opt-help + "Show this help message.") + (,@(shortform short-version) "version" #'opt-version + ("Show ~A's version number." *program-name*)) + (,@(shortform short-usage) "usage" #'opt-usage + ("Show a very brief usage summary for ~A." *program-name*)))))) + +(defun define-program (&key + (program-name nil progp) + (help nil helpp) + (version nil versionp) + (usage nil usagep) + (full-usage nil fullp) + (options nil optsp)) + "Sets up all the required things a program needs to have to parse options + and respond to them properly." + (when progp (setf *program-name* program-name)) + (when helpp (setf *help* help)) + (when versionp (setf *version* version)) + (when optsp (setf *options* options)) + (cond ((and usagep fullp) (error "conflicting options")) + (usagep (setf *usage* (simple-usage *options* usage))) + (fullp (setf *usage* full-usage)))) + +(defmacro do-options ((&key (parser '(make-option-parser))) + &body clauses) + "Handy all-in-one options parser macro. PARSER defaults to a new options + parser using the preset default options structure. The CLAUSES are + `case2'-like clauses to match options, and must be exhaustive. If there + is a clause (nil (REST) FORMS...) then the FORMS are evaluated after + parsing is done with REST bound to the remaining command-line arguments." + (let*/gensyms (parser) + `(progn + (loop + (,(if (find t clauses :key #'car) 'case2 'ecase2) + (option-parse-next ,parser) + ((nil) () (return)) + ,@(remove-if #'null clauses :key #'car))) + ,@(let ((tail (find nil clauses :key #'car))) + (and tail + (destructuring-bind ((&optional arg) &rest forms) (cdr tail) + (if arg + (list `(let ((,arg (option-parse-remainder ,parser))) + ,@forms)) + forms))))))) + ;;;----- That's all, folks --------------------------------------------------