+;;; -*-lisp-*-
+;;;
+;;; $Id$
+;;;
+;;; Option parser, standard issue
+;;;
+;;; (c) 2005 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(defpackage #:mdw.optparse
+ (:use #:common-lisp #:mdw.base #:mdw.sys-base #:mdw.str)
+ (:export #:exit #:*program-name* #:*command-line-strings*
+ #:moan #:die
+ #:option #:optionp #:make-option
+ #:opt-short-name #:opt-long-name #:opt-tag #:opt-negated-tag
+ #:opt-arg-name #:opt-arg-optional-p #:opt-documentation
+ #:option-parser #:make-option-parser #:option-parser-p
+ #:op-options #:op-non-option #:op-long-only-p #:op-numeric-p
+ #:op-negated-numeric-p #:op-negated-p
+ #:option-parse-error
+ #:option-parse-remainder #:option-parse-next #:option-parse-try
+ #:with-unix-error-reporting
+ #:defopthandler #:invoke-option-handler
+ #:set #:clear #:inc #:dec #:read #:int #:string
+ #:keyword #:list
+ #:parse-option-form #:options
+ #:simple-usage #:show-usage #:show-version #:show-help
+ #:sanity-check-option-list))
+
+(in-package #:mdw.optparse)
+
+;;; Standard error-reporting functions.
+
+(defun moan (msg &rest args)
+ "Report an error message in the usual way."
+ (format *error-output* "~&~A: ~?~%" *program-name* msg args))
+(defun die (&rest args)
+ "Report an error message and exit."
+ (apply #'moan args)
+ (exit 1))
+
+;;; The main option parser.
+
+(defstruct (option (:predicate optionp)
+ (:conc-name opt-)
+ (:print-function
+ (lambda (o s k)
+ (declare (ignore k))
+ (format s
+ "#<option~@[ -~C,~]~@[ --~A~]~:[~2*~;~:[=~A~;[=~A]~]~]~@[ ~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))))
+ "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.
+
+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.
+
+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.
+
+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."
+ (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)))
+
+(defstruct (option-parser (:conc-name op-)
+ (:constructor make-option-parser
+ (argstmp
+ options
+ &key
+ (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*.
+
+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
+
+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!
+
+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)))
+ (next nil :type list)
+ (short-opt nil :type (or null string))
+ (short-opt-index 0 :type fixnum)
+ (short-opt-neg-p nil :type t)
+ (long-only-p nil :type t)
+ (numeric-p nil :type t)
+ (negated-numeric-p nil :type t)
+ (negated-p nil :type t))
+
+(define-condition option-parse-error (error simple-condition)
+ ()
+ (: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."
+ (error (make-condition 'option-parse-error
+ :format-control msg
+ :format-arguments args)))
+
+(defun option-parse-remainder (op)
+ "Returns the unparsed remainder of the command line."
+ (cdr (op-args op)))
+
+(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))
+ (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)))))))))))))
+
+(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."
+ (with-gensyms (retcode)
+ `(let ((,retcode t))
+ (restart-case
+ (handler-bind
+ ((option-parse-error
+ (lambda (cond)
+ (setf ,retcode nil)
+ (moan "~A" cond)
+ (dolist (rn '(skip-option stop-parsing))
+ (let ((r (find-restart rn)))
+ (when r (invoke-restart r)))))))
+ ,@body)
+ (stop-parsing ()
+ :report "Give up parsing options."
+ (setf ,retcode nil)))
+ ,retcode)))
+
+(defmacro with-unix-error-reporting ((&key) &body body)
+ "Evaluate BODY with errors reported in the standard Unix fashion."
+ (with-gensyms (cond)
+ `(handler-case
+ (progn ,@body)
+ (simple-condition (,cond)
+ (die (simple-condition-format-control ,cond)
+ (simple-condition-format-arguments ,cond)))
+ (error (,cond)
+ (die "~A" ,cond)))))
+
+;;; Standard option handlers.
+
+(defmacro defopthandler (name (var &optional (arg (gensym)))
+ (&rest args)
+ &body body)
+ "Define an option handler function NAME. Option handlers update a
+generalized variable, which may be referred to as VAR in the BODY, based on
+some parameters (the ARGS) and the value of an option-argument named ARG."
+ (let ((func (intern (format nil "OPTHANDLER/~:@(~A~)" name))))
+ `(progn
+ (setf (get ',name 'opthandler) ',func)
+ (defun ,func (,var ,arg ,@args)
+ (with-locatives ,var
+ (declare (ignorable ,arg))
+ ,@body))
+ ',name)))
+
+(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)))
+ (labels ((simple (a i r goodp sgn)
+ (loop
+ (when (>= i end)
+ (return (values (and goodp (* a sgn)) i)))
+ (let ((d (digit-char-p (char string i) r)))
+ (unless d
+ (return (values (and goodp (* a sgn)) i)))
+ (setf a (+ (* a r) d))
+ (setf goodp t)
+ (incf i))))
+ (get-radix (i r sgn)
+ (cond (r (simple 0 i r nil sgn))
+ ((>= i end) (values nil i))
+ ((and (char= (char string i) #\0)
+ (>= (- end i) 2))
+ (case (char string (1+ i))
+ (#\x (simple 0 (+ i 2) 16 nil sgn))
+ (#\o (simple 0 (+ i 2) 8 nil sgn))
+ (#\b (simple 0 (+ i 2) 2 nil sgn))
+ (t (simple 0 (1+ i) 8 t sgn))))
+ (t
+ (multiple-value-bind
+ (r i)
+ (simple 0 i 10 nil +1)
+ (cond ((not r) (values nil i))
+ ((and (< i end)
+ (char= (char string i) #\_)
+ (<= 2 r 36))
+ (simple 0 (1+ i) r nil sgn))
+ (t
+ (values (* r sgn) i))))))))
+ (cond ((>= start end) (values nil start))
+ ((char= (char string start) #\-)
+ (get-radix (1+ start) radix -1))
+ ((char= (char string start) #\+)
+ (get-radix (1+ start) radix +1))
+ (t
+ (get-radix start radix +1)))))
+
+(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."
+ (apply (if (functionp handler) handler
+ (fdefinition (get handler 'opthandler)))
+ loc
+ arg
+ args))
+
+(defopthandler set (var) (&optional (value t))
+ "Sets VAR to VALUE; defaults to t."
+ (setf var value))
+(defopthandler clear (var) (&optional (value nil))
+ "Sets VAR to VALUE; defaults to nil."
+ (setf var value))
+(defopthandler inc (var) (&optional max (step 1))
+ "Increments VAR by STEP (defaults to 1), but not greater than MAX (default
+nil for no maximum). No errors are signalled."
+ (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."
+ (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."
+ (handler-case
+ (let ((*read-eval* nil))
+ (multiple-value-bind (x end) (read-from-string arg t)
+ (unless (>= end (length arg))
+ (option-parse-error "Junk at end of argument `~A'" arg))
+ (setf var x)))
+ (error (cond)
+ (option-parse-error (format nil "~A" cond)))))
+(defopthandler int (var arg) (&key radix min max)
+ "Stores in VAR the integer read from the ARG. Integers are parsed
+according to C rules, which is normal in Unix; the RADIX may be nil to allow
+radix prefixes, or an integer between 2 and 36. An option-parse-error is
+signalled if the ARG is not a valid integer, or if it is not between MIN and
+MAX (either of which may be nil if no lower resp. upper bound is wanted)."
+ (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~])"
+ arg min max))
+ (setf var v)))
+(defopthandler string (var arg) ()
+ "Stores ARG in VAR, just as it is."
+ (setf var arg))
+(defopthandler keyword (var arg) (&rest valid)
+ (if (null valid)
+ (setf var (intern (string-upcase arg) :keyword))
+ (let ((matches nil)
+ (guess (string-upcase arg))
+ (len (length arg)))
+ (dolist (k valid)
+ (let* ((kn (symbol-name k))
+ (klen (length kn)))
+ (cond ((string= kn guess)
+ (setf matches (list k))
+ (return))
+ ((and (< len klen)
+ (string= guess kn :end2 len))
+ (push k matches)))))
+ (case (length matches)
+ (0 (option-parse-error "Argument `~A' invalid: must be one of:~
+ ~{~%~8T~(~A~)~}"
+ arg valid))
+ (1 (setf var (car matches)))
+ (t (option-parse-error "Argument `~A' ambiguous: may be any of:~
+ ~{~%~8T~(~A~)~}"
+ arg matches))))))
+(defopthandler 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'."
+ (when handler
+ (invoke-option-handler handler (locf arg) arg handler-args))
+ (setf var (nconc var (list arg))))
+
+(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."
+ (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))))))
+ (if (and (docp (car form))
+ (null (cdr form)))
+ `(%make-option :documentation ,(doc (car form)))
+ (let (long-name short-name
+ arg-name arg-optional-p
+ tag negated-tag
+ doc)
+ (dolist (f form)
+ (cond ((and (or (not tag) (not negated-tag))
+ (or (keywordp f)
+ (and (consp f)
+ (member (car f) '(lambda function)))))
+ (if tag
+ (setf negated-tag f)
+ (setf tag f)))
+ ((and (not long-name)
+ (or (rationalp f)
+ (symbolp f)
+ (stringp f)))
+ (setf long-name (if (stringp f) f
+ (format nil "~(~A~)" f))))
+ ((and (not short-name)
+ (characterp f))
+ (setf short-name f))
+ ((and (not doc)
+ (docp f))
+ (setf doc (doc f)))
+ ((and (consp f) (symbolp (car f)))
+ (case (car f)
+ (:arg (setf arg-name (cadr f)))
+ (:opt-arg (setf arg-name (cadr f))
+ (setf arg-optional-p t))
+ (:doc (setf doc (doc (cdr f))))
+ (t (let ((handler (get (car f) 'opthandler)))
+ (unless handler
+ (error "No handler `~S' defined." (car f)))
+ (let* ((var (cadr f))
+ (arg (gensym))
+ (thunk `#'(lambda (,arg)
+ (,handler (locf ,var)
+ ,arg
+ ,@(cddr f)))))
+ (if tag
+ (setf negated-tag thunk)
+ (setf tag thunk)))))))
+ (t
+ (error "Unexpected thing ~S in option form." f))))
+ `(make-option ,long-name ,short-name ,arg-name
+ ,@(and arg-optional-p `(:arg-optional-p t))
+ ,@(and tag `(:tag ,tag))
+ ,@(and negated-tag `(:negated-tag ,negated-tag))
+ ,@(and doc `(:documentation ,doc)))))))
+
+(defmacro options (&rest optlist)
+ "More convenient way of initializing options. The OPTLIST is a list of
+OPTFORMS. Each OPTFORM is either a banner string, or a list of
+items. Acceptable items are interpreted as follows:
+
+ KEYWORD or FUNCTION
+ If no TAG is set yet, then as a TAG; otherwise as the NEGATED-TAG.
+
+ STRING (or SYMBOL or RATIONAL)
+ If no LONG-NAME seen yet, then the LONG-NAME. For symbols and rationals,
+ the item is converted to a string and squashed to lower-case.
+
+ CHARACTER
+ The SHORT-NAME.
+
+ STRING or (STRING STUFF...)
+ If no DOCUMENTATION set yet, then the DOCUMENTATION string. A string is
+ used as-is; a list is considered to be a `format' string and its
+ arguments. This is evaluated at standard evaluation time: the option
+ structure returned contains a simple documentation string.
+
+ (:ARG NAME)
+ Set the ARG-NAME.
+
+ (:OPT-ARG NAME)
+ Set the ARG-NAME, and also set ARG-OPTIONAL-P.
+
+ (HANDLER VAR ARGS...)
+ If no TAG is set yet, attach the HANDLER to this option, giving it ARGS.
+ Otherwise, set the NEGATED-TAG."
+ `(list ,@(mapcar (lambda (form)
+ (if (stringp form)
+ `(%make-option :documentation ,form)
+ (parse-option-form form)))
+ optlist)))
+
+;;; 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))))))
+
+(defun simple-usage (opts &optional mandatory-args)
+ "Build a simple usage list from a list of options, and (optionally)
+mandatory argument names."
+ (let (short-simple long-simple short-arg long-arg)
+ (dolist (o opts)
+ (cond ((not (and (opt-documentation o)
+ (opt-long-name o))))
+ ((and (opt-short-name o) (opt-arg-name o))
+ (push o short-arg))
+ ((opt-short-name o)
+ (push o short-simple))
+ ((opt-arg-name o)
+ (push o long-arg))
+ (t
+ (push o long-simple))))
+ (list
+ (nconc (and short-simple
+ (list (format nil "[-~{~C~}]"
+ (sort (mapcar #'opt-short-name short-simple)
+ #'char<))))
+ (and long-simple
+ (mapcar (lambda (o)
+ (format nil "[--~A]" (opt-long-name o)))
+ (sort long-simple #'string< :key #'opt-long-name)))
+ (and short-arg
+ (mapcar (lambda (o)
+ (format nil "~:[[-~C ~A]~;[-~C[~A]]~]"
+ (opt-arg-optional-p o)
+ (opt-short-name o)
+ (opt-arg-name o)))
+ (sort short-arg #'char-lessp
+ :key #'opt-short-name)))
+ (and long-arg
+ (mapcar (lambda (o)
+ (format nil "~:[[--~A ~A]~;[--~A[=~A]]~]"
+ (opt-arg-optional-p o)
+ (opt-long-name o)
+ (opt-arg-name o)))
+ (sort long-arg #'string-lessp
+ :key #'opt-long-name)))
+ (listify mandatory-args)))))
+
+(defun show-usage (prog usage &optional (stream *standard-output*))
+ "Basic usage-showing function. PROG is the program name, probable from
+*command-line-strings*. USAGE is a list of possible usages of the program,
+each of which is a list of items to be supplied by the user. In simple
+cases, a single string is sufficient."
+ (pprint-logical-block (stream nil :prefix "Usage: ")
+ (dolist (u (listify usage))
+ (pprint-logical-block (stream nil :prefix (format nil "~A " 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)
+ (let (newlinep)
+ (dolist (o opts)
+ (let ((doc (opt-documentation o)))
+ (cond ((not o))
+ ((not (opt-long-name o))
+ (when newlinep
+ (terpri stream)
+ (setf newlinep nil))
+ (pprint-logical-block (stream nil)
+ (print-text doc stream))
+ (terpri stream))
+ (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))
+ (when (opt-arg-name o)
+ (format stream "~:[=~A~;[=~A]~]"
+ (opt-arg-optional-p o)
+ (opt-arg-name o)))
+ (write-string " " stream)
+ (pprint-tab :line 30 1 stream)
+ (print-text doc stream))
+ (terpri 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."
+ (let ((problems nil)
+ (longs (make-hash-table :test #'equal))
+ (shorts (make-hash-table)))
+ (flet ((problem (msg &rest args)
+ (push (apply #'format nil msg args) problems)))
+ (dolist (o opts)
+ (push o (gethash (opt-long-name o) longs))
+ (push o (gethash (opt-short-name o) shorts)))
+ (maphash (lambda (k v)
+ (when (and k (cdr v))
+ (problem "Long name `--~A' reused in ~S" k v)))
+ longs)
+ (maphash (lambda (k v)
+ (when (and k (cdr v))
+ (problem "Short name `-~C' reused in ~S" k v)))
+ shorts)
+ problems)))
+
+;;;----- That's all, folks --------------------------------------------------
~mdw / lisp / commitdiff