;;; 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 #: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))
- #.(car '(#+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)
- (unless (zerop code)
- (format *error-output*
- "~&Exiting unsuccessfully with code ~D.~%" code))))
- (abort))
-
(export '(*program-name* *command-line*))
(defvar *program-name* "<unknown>"
"Program name, as retrieved from the command line.")
"Retrieve command-line arguments.
Set `*command-line*' and `*program-name*'."
-
- (setf *command-line*
- (let ((uiop-package (find-package :uiop))
- (cll-package (find-package :cl-launch)))
- (cons (or (and uiop-package
- (funcall (intern "ARGV0" uiop-package)))
- (and cll-package
- (some (intern "GETENV" cll-package)
- (list "__CL_ARGV0" "CL_LAUNCH_FILE")))
- #+sbcl (car sb-ext:*posix-argv*)
- #+cmu (car ext:*command-line-strings*)
- #+clisp (aref (ext:argv) 0)
- #+ecl (ext:argv 0)
- "sod")
- (cond (uiop-package
- (funcall (intern "COMMAND-LINE-ARGUMENTS"
- uiop-package)))
- (cll-package
- (symbol-value (intern "*ARGUMENTS*" cll-package)))
- (t #.(or (car '(#+sbcl (cdr sb-ext:*posix-argv*)
- #+cmu (cdr ext:*command-line-strings*)
- #+clisp (coerce (subseq (ext:argv) 8)
- 'list)
- #+ecl (loop for i from 1
- below (ext:argc)
- collect (ext:argv i))))
- (error "Unsupported Lisp"))))))
-
+ (setf *command-line* (cons (uiop:argv0) uiop:*command-line-arguments*)
*program-name* (pathname-name (car *command-line*))))
;;;--------------------------------------------------------------------------
(defun die (&rest args)
"Report an error message and exit."
(apply #'moan args)
- (exit 1))
+ (uiop:quit 1))
;;;--------------------------------------------------------------------------
;;; The main option parser.
(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
- (&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:
+(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
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)))
+ (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
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)
(non-option :skip :type (or function (member :skip :stop :return)))
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)))
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
(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)))
(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) #\-)
(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)
(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)
(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
(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))
(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
(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))
;;;--------------------------------------------------------------------------
(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)))
"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)
"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
- or 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))
(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."
(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."
(multiple-value-bind (docs decls body) (parse-body body)
`(progn
- (setf (get ',name 'optmacro) (lambda ,args
- ,@docs ,@decls
- (block ,name ,@body)))
+ (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)
(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."
- (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.
((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))))))
;;;--------------------------------------------------------------------------
;;; 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)
(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)))
(export 'die-usage)
(defun die-usage ()
(do-usage *error-output*)
- (exit 1))
+ (uiop:quit 1))
(defun opt-help (arg)
(declare (ignore arg))
(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)
(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))
~mdw / sod / blobdiff