;;; 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.
;;; Packages.
(defpackage #:optparse
- (:use #:common-lisp #:mdw.base #:mdw.sys-base #:mdw.str)
- (:export #:exit #:*program-name* #:*command-line-strings*
+ (:use #:common-lisp #:mdw.base #:mdw.sys-base)
+ (:export #:exit #:*program-name* #:*command-line*
#:moan #:die
#:option #:optionp #:make-option
#:opt-short-name #:opt-long-name #:opt-tag #:opt-negated-tag
(defvar *options* nil)
-(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))))
+(defstruct (option
+ (:predicate optionp)
+ (:conc-name opt-)
+ (:print-function
+ (lambda (o s k)
+ (declare (ignore k))
+ (print-unreadable-object (o s :type t)
+ (format s "~@[-~C, ~]~@[--~A~]~
+ ~*~@[~2:*~:[=~A~;[=~A]~]~]~
+ ~@[ ~S~]"
+ (opt-short-name o)
+ (opt-long-name o)
+ (opt-arg-optional-p o)
+ (opt-arg-name o)
+ (opt-documentation o)))))
+ (:constructor %make-option)
+ (:constructor make-option
+ (long-name short-name
+ &optional arg-name
+ &key (tag (intern (string-upcase long-name) :keyword))
+ negated-tag
+ arg-optional-p
+ doc (documentation doc))))
"Describes a command-line option. Slots:
LONG-NAME The option's long name. If this is null, the `option' is
NEGATED-TAG As for TAG, but used if the negated form of the option is
found. If this is nil (the default), the option cannot be
- negated.
+ negated.
SHORT-NAME The option's short name. This must be a single character, or
nil if the option has no short name.
(arg-optional-p nil :type t)
(documentation nil :type (or null string)))
-(defstruct (option-parser (:conc-name op-)
- (:constructor make-option-parser
- (&key
- ((:args argstmp)
- (cdr *command-line-strings*))
- (options *options*)
- (non-option :skip)
- ((:numericp numeric-p))
- negated-numeric-p
- long-only-p
- &aux
- (args (cons nil argstmp))
- (next args)
- (negated-p (or negated-numeric-p
- (some
- #'opt-negated-tag
- options))))))
+(defstruct (option-parser
+ (:conc-name op-)
+ (:constructor make-option-parser
+ (&key ((:args argstmp) (cdr *command-line*))
+ (options *options*)
+ (non-option :skip)
+ ((:numericp numeric-p))
+ negated-numeric-p
+ long-only-p
+ &aux (args (cons nil argstmp))
+ (next args)
+ (negated-p (or negated-numeric-p
+ (some #'opt-negated-tag
+ options))))))
"An option parser object. Slots:
ARGS The arguments to be parsed. Usually this will be
- *command-line-strings*.
+ *command-line*.
OPTIONS List of option structures describing the acceptable options.
(setf arg (get-arg)))
(t
(option-parse-error "Option `~A' requires an argument"
- name)))
+ name)))
(let ((how (if negp (opt-negated-tag o) (opt-tag o))))
(if (functionp how)
(funcall how arg)
(option-parse-error "Unknown option `~A'" optname))
((cdr matches)
(option-parse-error
- "~
-Ambiguous long option `~A' -- could be any of:~{~% --~A~}"
+ #.(concatenate 'string
+ "Ambiguous long option `~A' -- "
+ "could be any of:"
+ "~{~%~8T--~A~}")
optname
(mapcar #'opt-long-name matches))))
(process-option (car matches)
(progn ,@body)
(simple-condition (,cond)
(apply #'die
- (simple-condition-format-control ,cond)
- (simple-condition-format-arguments ,cond)))
+ (simple-condition-format-control ,cond)
+ (simple-condition-format-arguments ,cond)))
(error (,cond)
(die "~A" ,cond)))))
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)))
+ (with-parsed-body (body decls docs) body
+ `(progn
+ (setf (get ',name 'opthandler) ',func)
+ (defun ,func (,var ,arg ,@args)
+ ,@docs ,@decls
+ (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
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)))
+ (setf-default end (length string))
(labels ((simple (i r goodp sgn)
(multiple-value-bind
(a i)
(when (or (and min (< v min))
(and max (> v max)))
(option-parse-error
- "Integer ~A out of range (must have ~@[~D <= ~]x~@[ <= ~D~])"
+ #.(concatenate 'string
+ "Integer ~A out of range "
+ "(must have ~@[~D <= ~]x~@[ <= ~D~])")
arg min max))
(setf var v)))
"Stores ARG in VAR, just as it is."
(setf var arg))
-(defopthandler keyword (var arg) (&rest valid)
- (if (null valid)
- (setf var (intern (string-upcase arg) :keyword))
- (let ((matches nil)
- (guess (string-upcase arg))
- (len (length arg)))
- (dolist (k valid)
- (let* ((kn (symbol-name k))
- (klen (length kn)))
- (cond ((string= kn guess)
- (setf matches (list k))
- (return))
- ((and (< len klen)
- (string= guess kn :end2 len))
- (push k matches)))))
- (case (length matches)
- (0 (option-parse-error "Argument `~A' invalid: must be one of:~
- ~{~%~8T~(~A~)~}"
- arg valid))
- (1 (setf var (car matches)))
- (t (option-parse-error "Argument `~A' ambiguous: may be any of:~
- ~{~%~8T~(~A~)~}"
- arg matches))))))
+(defopthandler keyword (var arg) (&optional (valid t))
+ "Converts ARG into a keyword. If VALID is t, then any ARG string is
+ acceptable: the argument is uppercased and interned in the keyword
+ package. If VALID is a list, then we ensure that ARG matches one of the
+ elements of the list; unambigious abbreviations are allowed."
+ (etypecase valid
+ ((member t)
+ (setf var (intern (string-upcase arg) :keyword)))
+ (list
+ (let ((matches nil)
+ (guess (string-upcase arg))
+ (len (length arg)))
+ (dolist (k valid)
+ (let* ((kn (symbol-name k))
+ (klen (length kn)))
+ (cond ((string= kn guess)
+ (setf matches (list k))
+ (return))
+ ((and (< len klen)
+ (string= guess kn :end2 len))
+ (push k matches)))))
+ (cond
+ ((null matches)
+ (option-parse-error #.(concatenate 'string
+ "Argument `~A' invalid: "
+ "must be one of:"
+ "~{~%~8T~(~A~)~}")
+ arg valid))
+ ((null (cdr matches))
+ (setf var (car matches)))
+ (t
+ (option-parse-error #.(concatenate 'string
+ "Argument `~A' ambiguous: "
+ "may be any of:"
+ "~{~%~8T~(~A~)~}")
+ arg matches)))))))
(defopthandler list (var arg) (&optional handler &rest handler-args)
"Collect ARGs in a list at VAR. ARGs are translated by the HANDLER first,
(t
(error "Unexpected thing ~S in option form." f))))
`(make-option ,long-name ,short-name ,arg-name
- ,@(and arg-optional-p `(:arg-optional-p t))
- ,@(and tag `(:tag ,tag))
- ,@(and negated-tag `(:negated-tag ,negated-tag))
- ,@(and doc `(:documentation ,doc))))))))
+ ,@(and arg-optional-p `(:arg-optional-p t))
+ ,@(and tag `(:tag ,tag))
+ ,@(and negated-tag `(:negated-tag ,negated-tag))
+ ,@(and doc `(:documentation ,doc))))))))
(defmacro options (&rest optlist)
"More convenient way of initializing options. The OPTLIST is a list of
STRING A banner to print.
SYMBOL or (SYMBOL STUFF...)
- If SYMBOL is an optform macro, the result of invoking it.
+ If SYMBOL is an optform macro, the result of invoking it.
(...) A full option-form. See below.
(flet ((emit ()
(write-string string stream :start start :end i)
(setf start i)))
- (unless end
- (setf end (length string)))
+ (setf-default end (length string))
(loop
(unless (< i end)
(emit)
(defun show-usage (prog usage &optional (stream *standard-output*))
"Basic usage-showing function. PROG is the program name, probably from
- *command-line-strings*. USAGE is a list of possible usages of the
- program, each of which is a list of items to be supplied by the user. In
- simple cases, a single string is sufficient."
+ *command-line*. USAGE is a list of possible usages of the program, each
+ of which is a list of items to be supplied by the user. In simple cases,
+ a single string is sufficient."
(pprint-logical-block (stream nil :prefix "Usage: ")
(dolist (u (listify usage))
- (pprint-logical-block (stream nil :prefix (format nil "~A " prog))
+ (pprint-logical-block (stream nil
+ :prefix (concatenate 'string prog " "))
(format stream "~{~A ~:_~}" (listify u)))
(pprint-newline :mandatory stream))))
-(defun show-help (prog ver usage opts &optional (stream *standard-output*))
- "Basic help-showing function. PROG is the program name, probably from
- *command-line-strings*. VER is the program's version number. USAGE is a
- list of the possible usages of the program, each of which may be a list of
- items to be supplied. OPTS is the list of supported options, as provided
- to the options parser. STREAM is the stream to write on."
- (format stream "~A, version ~A~2%" prog ver)
- (show-usage prog usage stream)
- (terpri stream)
+(defun show-options-help (opts &optional (stream *standard-output*))
+ "Write help for OPTS to the STREAM. This is the core of the `show-help'
+ function."
(let (newlinep)
(dolist (o opts)
(let ((doc (opt-documentation o)))
(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))
(opt-arg-name o)))
(write-string " " stream)
(pprint-tab :line 30 1 stream)
+ (pprint-indent :block 30 stream)
(print-text doc stream))
(terpri stream)))))))
+(defun show-help (prog ver usage opts &optional (stream *standard-output*))
+ "Basic help-showing function. PROG is the program name, probably from
+ *command-line*. VER is the program's version number. USAGE is a list of
+ the possible usages of the program, each of which may be a list of items
+ to be supplied. OPTS is the list of supported options, as provided to the
+ options parser. STREAM is the stream to write on."
+ (format stream "~A, version ~A~2%" prog ver)
+ (show-usage prog usage stream)
+ (terpri stream)
+ (show-options-help opts stream))
+
(defun sanity-check-option-list (opts)
"Check the option list OPTS for basic sanity. Reused short and long option
names are diagnosed. Maybe other problems will be reported later.
(show-help *program-name* *version* *usage* *options*)
(typecase *help*
(string (terpri) (write-string *help*))
+ (null nil)
((or function symbol) (terpri) (funcall *help*)))
(format t "~&")
(exit 0))
~mdw / lisp / blobdiff