From: Mark Wooding Date: Mon, 24 Apr 2006 14:30:23 +0000 (+0100) Subject: base, optparse: Various option-parsing enhancements. X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/lisp/commitdiff_plain/b3bc37457df55c92cabc8aeeb42bc67d3fb8af12 base, optparse: Various option-parsing enhancements. * `case2' clauses can optionally bind a variable to its scrutinee. * New function `option-parse-return' to return a value from `option-parse-next'. * Enhance `options' parse-option-form' to understand disambiguating keywords arguments for all option slots. This also means that these things can be set from expressions rather than constants. * Default the `define-program' variables sensibly. * Make `do-options' use `let*/gensyms'. * Make the optparse test use the convenience macros. * Rename `help-opts' to `help-options'. Just because. And tidy up the code a bunch. --- diff --git a/mdw-base.lisp b/mdw-base.lisp index cde1d7a..6b235f5 100644 --- a/mdw-base.lisp +++ b/mdw-base.lisp @@ -179,21 +179,26 @@ (compile-time-defun do-case2-like (kind vform clauses) (,kind ,scrutinee ,@(mapcar (lambda (clause) (destructuring-bind - (cases (&optional var) &rest forms) + (cases (&optional varx vary) &rest forms) clause `(,cases - ,@(if var - (list `(let ((,var ,argument)) ,@forms)) + ,@(if varx + (list `(let ((,(or vary varx) ,argument) + ,@(and vary + `((,varx ,scrutinee)))) + ,@forms)) forms)))) clauses))))) (defmacro case2 (vform &body clauses) "VFORM is a form which evaluates to two values, SCRUTINEE and ARGUMENT. - The CLAUSES have the form (CASES ([VAR]) FORMS...), where a standard - `case' clause has the form (CASES FORMS...). The `case2' form evaluates - the VFORM, and compares the SCRUTINEE to the various CASES, in order, just - like `case'. If there is a match, then the corresponding FORMs are - evaluated with VAR (if specified) bound to the value of ARGUMENT." + The CLAUSES have the form (CASES ([[SCRUVAR] ARGVAR]) FORMS...), where a + standard `case' clause has the form (CASES FORMS...). The `case2' form + evaluates the VFORM, and compares the SCRUTINEE to the various CASES, in + order, just like `case'. If there is a match, then the corresponding + FORMs are evaluated with ARGVAR bound to the ARGUMENT and SCRUVAR bound to + the SCRUTINEE (where specified). Note the bizarre defaulting behaviour: + ARGVAR is less optional than SCRUVAR." (do-case2-like 'case vform clauses)) (defmacro ecase2 (vform &body clauses) diff --git a/optparse-test b/optparse-test index 2677caa..0fe74b9 100755 --- a/optparse-test +++ b/optparse-test @@ -12,66 +12,81 @@ (defvar opt-keyword nil) (defvar opt-enum nil) (defvar opt-counter 2) +(defvar opt-object nil) -(defconstant options - (options - "Help options" - (#\h "help" - (lambda (arg) - (declare (ignore arg)) - (show-help *program-name* "1.0.0" "usage-blah" options) - (exit 0)) - ("Show this help text.")) - ( "version" - (lambda (arg) - (declare (ignore arg)) - (format t "~A, version ~A~%" *program-name* "1.0.0") - (exit 0)) - ("Show ~A's version number." *program-name*)) - "Test options" - (#\b "boolean" (set opt-bool) (clear opt-bool) - ("Set (or clear, if negated) the boolean flag.")) - (#\i "integer" (:arg "INT") (int opt-int :min -10 :max 10) - ("Set an integer between -10 and +10.")) - (#\l "list" (:arg "STRING") (list opt-list) - ("Stash an item in the string list.")) - (#\I "int-list" (:arg "INT") - (list opt-int-list 'int :min -10 :max 10) - ("Stash an integer between -10 and +10 in the int list.")) - (#\s "string" (:arg "STRING") (string opt-string) - ("Set a string.")) - (#\q "quiet" (dec opt-counter 0) - ("Be more quiet.")) - (#\v "verbose" (inc opt-counter 5) - ("Be more verbose.")) - (#\Q "very-quiet" (dec opt-counter 0 3) - ("Be much more quiet.")) - (#\V "very-verbose" (inc opt-counter 5 3) - ("Be much more verbose.")) - (#\k "keywword" (:arg "KEYWORD") (keyword opt-keyword) - ("Set an arbitrary keyword.")) - (#\e "enumeration" (:arg "ENUM") - (keyword opt-enum :apple :apple-pie :abacus :banana) - ("Set a keyword from a fixed set.")))) +(define-program + :help "This program exists to test the Lisp options parser." + :usage "ARGUMENTS..." + :version "1.0.0" + :options (options + (help-options :short-version nil) + "Test options" + (#\b "boolean" (set opt-bool) (clear opt-bool) + ("Set (or clear, if negated) the boolean flag.")) + (#\i "integer" (:arg "INT") (int opt-int :min -10 :max 10) + ("Set an integer between -10 and +10.")) + (#\l "list" (:arg "STRING") (list opt-list) + ("Stash an item in the string list.")) + (#\I "int-list" (:arg "INT") + (list opt-int-list 'int :min -10 :max (+ 5 5)) + ("Stash an integer between -10 and +10 in the int list.")) + (#\s "string" (:arg "STRING") (string opt-string) + ("Set a string.")) + (#\q "quiet" (dec opt-counter 0) + ("Be more quiet.")) + (#\v "verbose" (inc opt-counter 5) + ("Be more verbose.")) + (#\Q "very-quiet" (dec opt-counter 0 3) + ("Be much more quiet.")) + (#\V "very-verbose" (inc opt-counter 5 3) + ("Be much more verbose.")) + ((:short-name #\o) + (:long-name "object") + (:arg "OBJECT") + (read opt-object) + (:doc (concatenate 'string + "Read object (" + (format-universal-time nil + (get-universal-time) + :style :iso8601) + ")"))) + (#\k "keywword" (:arg "KEYWORD") (keyword opt-keyword) + ("Set an arbitrary keyword.")) + (#\e "enumeration" (:arg "ENUM") + (keyword opt-enum :apple :apple-pie :abacus :banana) + ("Set a keyword from a fixed set.")) + (#\x "xray" (:arg "WAVELENGTH") + "Report an option immediately.") + (#\y "yankee" :yankee :no-yankee + "Report an option immediately.") + (#\z "zulu" (:opt-arg "TRIBE") + (lambda (arg) + (when (and (plusp (length arg)) + (char-equal (char arg 0) #\z)) + (option-parse-return :zzulu arg)) + (format t "Ignoring insufficiently zeddy Zulu ~A~%" arg)) + "Report an option immediately."))) (defun test (args) - (let ((op (make-option-parser :args (cdr args) :options options))) - (unless (option-parse-try - (loop - (multiple-value-bind (opt arg) (option-parse-next op) - (unless opt (return)) - (format t "Option ~S: `~A'~%" opt arg)))) - (exit 1)) - (format t "Non-option arguments: ~S~%" (option-parse-remainder op)) - (format t "boolean: ~S~%" opt-bool) - (format t "integer: ~S~%" opt-int) - (format t "list: ~S~%" opt-list) - (format t "int-list: ~S~%" opt-int-list) - (format t "string : ~S~%" opt-string) - (format t "counter: ~S~%" opt-counter) - (format t "keyword: ~S~%" opt-keyword) - (format t "enum: ~S~%" opt-enum))) -(test *command-line-strings*) + (unless (option-parse-try + (do-options (:parser (make-option-parser :args args)) + (:xray (arg) + (format t "Emitting X-ray of wavelength ~A nm~%" arg)) + (t (opt arg) + (format t "Option ~S: `~A'~%" opt arg)) + (nil (rest) + (format t "Non-option arguments: ~S~%" rest)))) + (die-usage)) + (format t "boolean: ~S~%" opt-bool) + (format t "integer: ~S~%" opt-int) + (format t "list: ~S~%" opt-list) + (format t "int-list: ~S~%" opt-int-list) + (format t "string : ~S~%" opt-string) + (format t "counter: ~S~%" opt-counter) + (format t "keyword: ~S~%" opt-keyword) + (format t "enum: ~S~%" opt-enum) + (format t "object: ~S~%" opt-object)) +(test (cdr *command-line-strings*)) diff --git a/optparse.lisp b/optparse.lisp index acbe11f..9f835fc 100644 --- a/optparse.lisp +++ b/optparse.lisp @@ -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-) @@ -204,6 +205,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 +221,186 @@ (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)) - (t - (push o matches)))) - (cond ((null matches) - (option-parse-error "Unknown option `~A'" optname)) - ((cdr matches) - (option-parse-error - "~ + (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 + "~ 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))))))))))))) + 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 + (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 @@ -648,6 +656,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)) @@ -683,9 +695,21 @@ (defmacro options (&rest optlist) (...) 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. - KEYWORD or FUNCTION + (: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. @@ -694,25 +718,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...) - - (:DOC STRING STUFF...) - The DOCUMENATION string. With no STUFF, STRING is used as - is;otherwise the documentation string is computed by (format - nil STRING STUFF...). + as for (:doc STRING STUFF...) - (:ARG NAME) Set the ARG-NAME. - - (:OPT-ARG NAME) + (:opt-arg NAME) Set the ARG-NAME, and also set ARG-OPTIONAL-P. (HANDLER VAR ARGS...) If no TAG is set yet, attach the HANDLER to this option, giving it ARGS. Otherwise, set the NEGATED-TAG." + `(list ,@(mapcan (lambda (form) (multiple-value-bind (sym args) @@ -882,9 +900,16 @@ (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)) @@ -894,77 +919,68 @@ (defun opt-help (arg) ((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 --------------------------------------------------