X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/e8abb2862e1a3b5f5a296d4fc00fe1b8e3200b4b..refs/heads/mdw/progfmt:/src/optparse.lisp diff --git a/src/optparse.lisp b/src/optparse.lisp index a2ac290..a258699 100644 --- a/src/optparse.lisp +++ b/src/optparse.lisp @@ -7,7 +7,7 @@ ;;;----- Licensing notice --------------------------------------------------- ;;; -;;; This file is part of the Sensble Object Design, an object system for C. +;;; This file is part of the Sensible Object Design, an object system for C. ;;; ;;; SOD is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -23,32 +23,16 @@ ;;; along with SOD; if not, write to the Free Software Foundation, ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -(cl:defpackage #:optparse - (:use #:common-lisp #:cl-launch #:sod-utilities)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (handler-bind ((warning #'muffle-warning)) + (cl:defpackage #:optparse + (:use #:common-lisp #:sod-utilities)))) (cl:in-package #:optparse) ;;;-------------------------------------------------------------------------- ;;; Program environment things. -(export 'exit) -(defun exit (&optional (code 0) &key abrupt) - "End program, returning CODE to the caller." - (declare (type (unsigned-byte 32) code)) - #+sbcl (sb-ext:exit :code code :abort abrupt) - #+cmu (if abrupt - (unix::void-syscall ("_exit" c-call:int) code) - (ext:quit code)) - #+clisp (funcall (if abrupt #'ext:quit #'ext:exit) code) - #+ecl (ext:quit code) - - #-(or sbcl cmu clisp ecl) - (progn - (unless (zerop code) - (format *error-output* - "~&Exiting unsuccessfully with code ~D.~%" code)) - (abort))) - (export '(*program-name* *command-line*)) (defvar *program-name* "" "Program name, as retrieved from the command line.") @@ -60,16 +44,7 @@ "Retrieve command-line arguments. Set `*command-line*' and `*program-name*'." - - (setf *command-line* - (cons (or (getenv "CL_LAUNCH_FILE") - #+sbcl (car sb-ext:*posix-argv*) - #+cmu (car ext:*command-line-strings*) - #+clisp (aref (ext:argv) 0) - #+ecl (ext:argv 0) - #-(or sbcl cmu clisp ecl) "sod") - *arguments*) - + (setf *command-line* (cons (uiop:argv0) uiop:*command-line-arguments*) *program-name* (pathname-name (car *command-line*)))) ;;;-------------------------------------------------------------------------- @@ -124,7 +99,7 @@ (defun die (&rest args) "Report an error message and exit." (apply #'moan args) - (exit 1)) + (uiop:quit 1)) ;;;-------------------------------------------------------------------------- ;;; The main option parser. @@ -136,48 +111,62 @@ (export '(option optionp make-option opt-short-name opt-long-name opt-tag opt-negated-tag opt-arg-name opt-arg-optional-p opt-documentation)) -(defstruct (option - (:predicate optionp) - (:conc-name opt-) - (:print-function - (lambda (o s k) - (declare (ignore k)) - (print-unreadable-object (o s :type t) - (format s "~@[-~C, ~]~@[--~A~]~ - ~*~@[~2:*~:[=~A~;[=~A]~]~]~ - ~@[ ~S~]" - (opt-short-name o) - (opt-long-name o) - (opt-arg-optional-p o) - (opt-arg-name o) - (opt-documentation o))))) - (:constructor %make-option) - (:constructor make-option - (long-name short-name - &optional arg-name - &key (tag (intern (string-upcase long-name) :keyword)) - negated-tag - arg-optional-p - doc (documentation doc)))) - "Describes a command-line option. Slots: +(locally (declare #+sbcl (sb-ext:muffle-conditions style-warning)) + (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 "~*~:[~2:*~:[~3*~@[~S~]~ + ~;~ + ~:*-~C~ + ~2*~@[~:*~:[ ~A~;[~A]~]~]~ + ~@[ ~S~]~]~ + ~;~ + ~2:*~@[-~C, ~]--~A~ + ~*~@[~:*~:[=~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 + (&key long-name tag negated-tag short-name + arg-name arg-optional-p documentation + &aux (%documentation documentation))) + (: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) + &aux (%documentation + documentation)))) + "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. 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. + 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 + 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. - 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 @@ -185,31 +174,34 @@ DOCUMENTATION The help text for this option. It is automatically line- - wrapped. If nil, the option is omitted from the help + wrapped. If `nil', the option is omitted from the help text. - Usually, one won't use make-option, but use the option macro instead." - (long-name nil :type (or null string)) - (tag nil :type t) - (negated-tag nil :type t) - (short-name nil :type (or null character)) - (arg-name nil :type (or null string)) - (arg-optional-p nil :type t) - (documentation nil :type (or null string))) + Usually, one won't use `make-option', but use the `option' macro instead." + (long-name nil :type (or null string)) + (tag nil :type t) + (negated-tag nil :type t) + (short-name nil :type (or null character)) + (arg-name nil :type (or null string)) + (arg-optional-p nil :type t) + (%documentation nil :type (or null string)))) +(define-access-wrapper opt-documentation opt-%documentation) (export '(option-parser option-parser-p make-option-parser - op-options op-non-option op-long-only-p op-numeric-p - op-negated-numeric-p op-negated-p)) + op-options op-non-option op-long-only-p + op-numeric-p op-negated-numeric-p op-negated-p)) (defstruct (option-parser (:conc-name op-) (:constructor make-option-parser (&key ((:args argstmp) (cdr *command-line*)) (options *options*) - (non-option :skip) + (non-option (if (uiop:getenv "POSIXLY_CORRECT") :stop + :skip)) ((:numericp numeric-p)) negated-numeric-p long-only-p &aux (args (cons nil argstmp)) + (%options options) (next args) (negated-p (or negated-numeric-p (some #'opt-negated-tag @@ -223,27 +215,27 @@ NON-OPTION Behaviour when encountering a non-option argument. The default is :skip. Allowable values are: - :skip -- pretend that it appeared after the option + `:skip' -- pretend that it appeared after the option arguments; this is the default behaviour of GNU getopt - :stop -- stop parsing options, leaving the remaining + `:stop' -- stop parsing options, leaving the remaining command line unparsed - :return -- return :non-option and the argument word + `: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.) + 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! - LONG-ONLY-P A misnomer inherited from GNU getopt. Whether to allow + 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." + `nil'." (args nil :type list) - (options nil :type list) + (%options nil :type list) (non-option :skip :type (or function (member :skip :stop :return))) (next nil :type list) (short-opt nil :type (or null string)) @@ -253,6 +245,7 @@ (numeric-p nil :type t) (negated-numeric-p nil :type t) (negated-p nil :type t)) +(define-access-wrapper op-options op-%options) (export 'option-parse-error) (define-condition option-parse-error (error simple-condition) @@ -263,7 +256,7 @@ Probably not that useful.")) (defun option-parse-error (msg &rest args) - "Signal an option-parse-error with the given message and arguments." + "Signal an `option-parse-error' with the given message and arguments." (error (make-condition 'option-parse-error :format-control msg :format-arguments args))) @@ -287,10 +280,10 @@ This is 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 + `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 @@ -380,7 +373,7 @@ (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))) @@ -406,16 +399,16 @@ (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) #\-) @@ -428,12 +421,12 @@ (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) @@ -458,14 +451,14 @@ (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) @@ -484,8 +477,8 @@ (defmacro option-parse-try (&body body) "Report errors encountered while parsing options, and try to continue. - Also establishes a restart `stop-parsing'. Returns t if parsing completed - successfully, or nil if errors occurred." + 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 @@ -531,22 +524,33 @@ (let ((func (intern (format nil "OPTHANDLER/~:@(~A~)" name)))) (multiple-value-bind (docs decls body) (parse-body body) `(progn - (setf (get ',name 'opthandler) ',func) + (setf (get ',name 'opthandler-function) ',func) (defun ,func (,var ,arg ,@args) ,@docs ,@decls (declare (ignorable ,arg)) (with-locatives ,var - ,@body)) + (block ,name ,@body))) ',name)))) +(export 'opthandler) +(defmethod documentation ((symbol symbol) (doc-type (eql 'opthandler))) + (let ((func (get symbol 'opthandler-function))) + (and func (documentation func 'function)))) +(defmethod (setf documentation) + (string (symbol symbol) (doc-type (eql 'opthandler))) + (let ((func (get symbol 'optmacro-function))) + (unless func (error "No option handler defined with name `~S'." symbol)) + (setf (documentation func 'function) string))) + (defun parse-c-integer (string &key radix (start 0) end) "Parse (a substring of) STRING 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." + 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))) (labels ((simple (i r goodp sgn) (multiple-value-bind @@ -592,10 +596,12 @@ (export 'invoke-option-handler) (defun invoke-option-handler (handler loc arg args) - "Call HANDLER, giving it LOC to update, the option-argument ARG, and the - remaining ARGS." + "Call an option HANDLER. + + The handler is invoked to update the locative LOC, given an + option-argument ARG, and the remaining ARGS." (apply (if (functionp handler) handler - (fdefinition (get handler 'opthandler))) + (fdefinition (get handler 'opthandler-function))) loc arg args)) ;;;-------------------------------------------------------------------------- @@ -603,26 +609,30 @@ (export 'set) (defopthandler set (var) (&optional (value t)) - "Sets VAR to VALUE; defaults to t." + "Sets VAR to VALUE; defaults to `t'." (setf var value)) (export 'clear) (defopthandler clear (var) (&optional (value nil)) - "Sets VAR to VALUE; defaults to nil." + "Sets VAR to VALUE; defaults to `nil'." (setf var value)) (export 'inc) (defopthandler inc (var) (&optional max (step 1)) - "Increments VAR by STEP (defaults to 1), but not greater than MAX (default - nil for no maximum). No errors are signalled." + "Increments VAR by STEP (defaults to 1). + + If MAX is not `nil' then VAR will not be made larger than MAX. No errors + are signalled." (incf var step) (when (and max (>= var max)) (setf var max))) (export 'dec) (defopthandler dec (var) (&optional min (step 1)) - "Decrements VAR by STEP (defaults to 1), but not less than MIN (default nil - for no maximum). No errors are signalled." + "Decrements VAR by STEP (defaults to 1). + + If MIN is not `nil', then VAR will not be made smaller than MIN. No + errors are signalled." (decf var step) (when (and min (<= var min)) (setf var min))) @@ -632,7 +642,7 @@ "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." + 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) @@ -647,10 +657,10 @@ "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)." + 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 or 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)) @@ -672,7 +682,7 @@ (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 + 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." @@ -725,11 +735,25 @@ (defmacro defoptmacro (name args &body body) "Defines an option macro NAME. - Option macros should produce a list of expressions producing one option + Option macros should produce a list of expressions producing one `option' structure each." - `(progn - (setf (get ',name 'optmacro) (lambda ,args ,@body)) - ',name)) + (multiple-value-bind (docs decls body) (parse-body body) + `(progn + (setf (get ',name 'optmacro-function) + (lambda ,args + ,@docs ,@decls + (block ,name ,@body))) + ',name))) + +(export 'optmacro) +(defmethod documentation ((symbol symbol) (doc-type (eql 'optmacro))) + (let ((func (get symbol 'optmacro-function))) + (and func (documentation func t)))) +(defmethod (setf documentation) + (string (symbol symbol) (doc-type (eql 'optmacro))) + (let ((func (get symbol 'optmacro-function))) + (unless func (error "No option macro defined with name `~S'." symbol)) + (setf (documentation func t) string))) (export 'parse-option-form) (eval-when (:compile-toplevel :load-toplevel :execute) @@ -737,79 +761,81 @@ "Does the heavy lifting for parsing an option form. See the docstring for the `option' macro for details of the syntax." - (flet ((doc (form) - (cond ((stringp form) form) - ((null (cdr form)) (car form)) - (t `(format nil ,@form)))) - (docp (form) - (or (stringp form) - (and (consp form) - (stringp (car form)))))) - (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))))))))) + (flet ((doc (form) + (cond ((stringp form) form) + ((null (cdr form)) (car form)) + (t `(format nil ,@form)))) + (docp (form) + (or (stringp form) + (and (consp form) + (stringp (car form)))))) + (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-function))) + (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))))))))) (export 'options) (defmacro options (&rest optlist) - "More convenient way of initializing options. The OPTLIST is a list of - OPTFORMS. Each OPTFORM is one of the following: + "A more convenient way of initializing options. + + The OPTLIST is a list of OPTFORMS. Each OPTFORM is one of the following: STRING A banner to print. @@ -861,7 +887,7 @@ ((and (consp form) (symbolp (car form))) (values (car form) (cdr form))) (t (values nil nil))) - (let ((macro (and sym (get sym 'optmacro)))) + (let ((macro (and sym (get sym 'optmacro-function)))) (if macro (apply macro args) (list (parse-option-form form)))))) @@ -870,48 +896,51 @@ ;;;-------------------------------------------------------------------------- ;;; Support stuff for help and usage messages. -(defun print-text (string - &optional - (stream *standard-output*) - &key - (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." - (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))) - (loop - (unless (< i end) - (emit) - (return)) - (let ((ch (char string i))) - (cond ((char= ch #\newline) - (emit) - (incf start) - (pprint-newline :mandatory stream)) - ((whitespace-char-p ch) - (when (zerop nest) - (setf splitp t))) - (t - (when splitp - (emit) - (pprint-newline :fill stream)) - (setf splitp nil) - (case ch - (#\[ (incf nest)) - (#\] (when (plusp nest) (decf nest)))))) - (incf i)))))) +(locally (declare #+sbcl (sb-ext:muffle-conditions style-warning)) + (defun print-text (string + &optional (stream *standard-output*) + &key (start 0) (end nil)) + "Print and line-break STRING to a pretty-printed STREAM. + + The string is broken at whitespace and 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))) + (loop + (unless (< i end) + (emit) + (return)) + (let ((ch (char string i))) + (cond ((char= ch #\newline) + (emit) + (incf start) + (pprint-newline :mandatory stream)) + ((whitespace-char-p ch) + (when (zerop nest) + (setf splitp t))) + (t + (when splitp + (emit) + (pprint-newline :fill stream)) + (setf splitp nil) + (case ch + (#\[ (incf nest)) + (#\] (when (plusp nest) (decf nest)))))) + (incf i))))))) (export 'simple-usage) (defun simple-usage (opts &optional mandatory-args) - "Build a simple usage list from a list of options, and (optionally) - mandatory argument names." + "Build a simple usage list. + + The usage list is constructed from a list OPTS of `option' values, and + a list MANDATORY-ARGS of mandatory argument names; the latter defaults to + `nil' if omitted." (let (short-simple long-simple short-arg long-arg) (dolist (o opts) (cond ((not (and (opt-documentation o) @@ -975,22 +1004,25 @@ (dolist (o opts) (let ((doc (opt-documentation o))) (cond ((not o)) - ((not (opt-long-name o)) + ((not (or (opt-short-name o) + (opt-long-name o))) (when newlinep (terpri stream) (setf newlinep nil)) (pprint-logical-block (stream nil) (print-text doc stream)) (terpri stream)) - (t + (doc (setf newlinep t) (pprint-logical-block (stream nil :prefix " ") - (format stream "~:[ ~;-~:*~C,~] --~A" + (format stream "~:[ ~;-~:*~C~:[~;,~]~:*~]~@[ --~A~]" (opt-short-name o) (opt-long-name o)) (when (opt-arg-name o) - (format stream "~:[=~A~;[=~A]~]" + (format stream + "~:[~;[~]~:[~0@*~:[ ~;~]~*~;=~]~A~0@*~:[~;]~]" (opt-arg-optional-p o) + (opt-long-name o) (opt-arg-name o))) (write-string " " stream) (pprint-tab :line 30 1 stream) @@ -1014,9 +1046,10 @@ (export 'sanity-check-option-list) (defun sanity-check-option-list (opts) - "Check the option list OPTS for basic sanity. Reused short and long option - names are diagnosed. Maybe other problems will be reported later. - Returns a list of warning strings." + "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." (let ((problems nil) (longs (make-hash-table :test #'equal)) (shorts (make-hash-table))) @@ -1050,7 +1083,7 @@ (export 'die-usage) (defun die-usage () (do-usage *error-output*) - (exit 1)) + (uiop:quit 1)) (defun opt-help (arg) (declare (ignore arg)) @@ -1060,15 +1093,15 @@ (null nil) ((or function symbol) (terpri) (funcall *help*))) (format t "~&") - (exit 0)) + (uiop:quit 0)) (defun opt-version (arg) (declare (ignore arg)) (format t "~A, version ~A~%" *program-name* *version*) - (exit 0)) + (uiop:quit 0)) (defun opt-usage (arg) (declare (ignore arg)) (do-usage) - (exit 0)) + (uiop:quit 0)) (export 'help-options) (defoptmacro help-options (&key (short-help #\h) @@ -1095,8 +1128,15 @@ (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." + "Sets up all the required things a program needs to have to parse options. + + This is a simple shorthand for setting `*program-name*', `*help*', + `*version*', `*options*', and `*usage*' from the corresponding arguments. + If an argument is not given then the corresponding variable is left alone. + + The USAGE argument should be a list of mandatory argument names to pass to + `simple-usage'; FULL-USAGE should be a complete usage-token list. An + error will be signalled if both USAGE and FULL-USAGE are provided." (when progp (setf *program-name* program-name)) (when helpp (setf *help* help)) (when versionp (setf *version* version))