X-Git-Url: https://git.distorted.org.uk/~mdw/lisp/blobdiff_plain/560e118666d0a7c41a43e2d86e2f38e3b931ef14..0eed4749891adf0a7be89e786b8968ee805a8d41:/optparse.lisp diff --git a/optparse.lisp b/optparse.lisp index d5e2f10..a949128 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. @@ -27,8 +27,8 @@ ;;; Packages. (defpackage #:optparse - (:use #:common-lisp #:mdw.base #:mdw.sys-base #:mdw.str) - (:export #:exit #:*program-name* #:*command-line-strings* + (:use #:common-lisp #:mdw.base #:mdw.sys-base) + (: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 @@ #: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 @@ #: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,62 +66,61 @@ ;;;-------------------------------------------------------------------------- ;;; The main option parser. -(defvar *options*) - -(defstruct (option (:predicate optionp) - (:conc-name opt-) - (:print-function - (lambda (o s k) - (declare (ignore k)) - (format 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)))) +(defvar *options* nil) + +(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 - 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) @@ -129,51 +129,48 @@ Usually, one won't use make-option, but use the option macro instead." (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)))))) +(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*. + 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))) @@ -188,8 +185,9 @@ LONG-ONLY-P A misnomer inherited from GNU getopt. Whether to allow (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." @@ -201,199 +199,209 @@ not that useful.")) "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 @@ -418,8 +426,8 @@ completed successfully, or nil if errors occurred." (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))))) @@ -430,25 +438,29 @@ completed successfully, or nil if errors occurred." (&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 + (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 -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) @@ -491,7 +503,7 @@ sensible parse), and the index following the characters of the integer." (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 @@ -511,22 +523,22 @@ ARG, and the remaining ARGS." (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) @@ -538,17 +550,20 @@ of type option-parse-error is signalled." (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))) @@ -556,33 +571,46 @@ MAX (either of which may be nil if no lower resp. upper bound is wanted)." "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)))) @@ -592,14 +620,14 @@ if specified. If not, it's as if you asked for `string'." (defmacro defoptmacro (name args &body body) "Defines an option macro NAME. Option macros should produce a list of -expressions producing one option structure each." + 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)) @@ -641,6 +669,10 @@ 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)) @@ -660,53 +692,58 @@ the `option' macro for details of the syntax." (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)))))))) (defmacro options (&rest optlist) "More convenient way of initializing options. The OPTLIST is a list of -OPTFORMS. Each OPTFORM is one of the following: + OPTFORMS. Each OPTFORM is one of the following: + + STRING A banner to print. - STRING - A banner to print. + SYMBOL or (SYMBOL STUFF...) + If SYMBOL is an optform macro, the result of invoking it. - SYMBOL or (SYMBOL STUFF...) - If SYMBOL is an optform macro, the result of invoking it. + (...) A full option-form. See below. - (...) - A full option-form. See below. + Full option-forms are a list of the following kinds of items. -Full option-forms are as follows. + (: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. - KEYWORD or FUNCTION - If no TAG is set yet, then as a TAG; otherwise as the NEGATED-TAG. + (:doc FORMAT-CONTROL ARGUMENTS...) + As for (:doc (format nil FORMAT-CONTROL ARGUMENTS...)). - 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. + KEYWORD, (function ...), (lambda ...) + If no TAG is set yet, then as a TAG; otherwise as the + NEGATED-TAG. - CHARACTER - The SHORT-NAME. + 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. - STRING or (STRING STUFF...) - If no DOCUMENTATION set yet, then the DOCUMENTATION string, as for - (:DOC STRING STUFF...) + CHARACTER If no SHORT-NAME, then the SHORT-NAME. - (: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...). + STRING or (STRING STUFF...) + If no DOCUMENTATION set yet, then the DOCUMENTATION string, + as for (:doc STRING STUFF...) - (:ARG NAME) - Set the ARG-NAME. + (:opt-arg NAME) + Set the ARG-NAME, and also set ARG-OPTIONAL-P. - (: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." - (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) @@ -730,16 +767,15 @@ Full option-forms are as follows. (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) @@ -764,7 +800,7 @@ this makes usage messages work better." (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) @@ -806,24 +842,19 @@ mandatory argument names." (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))) @@ -838,7 +869,6 @@ the options parser. STREAM is the stream to write on." (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)) @@ -848,13 +878,25 @@ the options parser. STREAM is the stream to write on." (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))) @@ -876,84 +918,88 @@ list of warning strings." ;;;-------------------------------------------------------------------------- ;;; 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) - (with-gensyms (tparser) - `(let ((,tparser ,parser)) + 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 ,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 --------------------------------------------------