X-Git-Url: https://git.distorted.org.uk/~mdw/lisp/blobdiff_plain/a035dd4a8175317f19a35cd04568d1655fb8d417..0eed4749891adf0a7be89e786b8968ee805a8d41:/optparse.lisp diff --git a/optparse.lisp b/optparse.lisp index 5f28365..a949128 100644 --- a/optparse.lisp +++ b/optparse.lisp @@ -13,12 +13,12 @@ ;;; 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. @@ -27,8 +27,8 @@ ;;; 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 @@ -68,32 +68,29 @@ (defvar *options* nil) -(defstruct (option (:predicate optionp) - (:conc-name opt-) - (:print-function - (lambda (o s k) - (declare (ignore k)) - (format 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 @@ -105,7 +102,7 @@ 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. @@ -132,27 +129,24 @@ (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. @@ -256,7 +250,7 @@ (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) @@ -289,8 +283,10 @@ (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) @@ -430,8 +426,8 @@ Ambiguous long option `~A' -- could be any of:~{~% --~A~}" (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))))) @@ -446,13 +442,15 @@ Ambiguous long option `~A' -- could be any of:~{~% --~A~}" 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 + (with-parsed-body (body decls docs) body + `(progn + (setf (get ',name 'opthandler) ',func) + (defun ,func (,var ,arg ,@args) + ,@docs ,@decls (declare (ignorable ,arg)) - ,@body)) - ',name))) + (with-locatives ,var + ,@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 @@ -462,7 +460,7 @@ Ambiguous long option `~A' -- could be any of:~{~% --~A~}" 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) @@ -563,7 +561,9 @@ Ambiguous long option `~A' -- could be any of:~{~% --~A~}" (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))) @@ -594,14 +594,18 @@ Ambiguous long option `~A' -- could be any of:~{~% --~A~}" (push k matches))))) (cond ((null matches) - (option-parse-error "Argument `~A' invalid: must be one of:~ - ~{~%~8T~(~A~)~}" + (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 "Argument `~A' ambiguous: may be any of:~ - ~{~%~8T~(~A~)~}" + (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) @@ -688,10 +692,10 @@ Ambiguous long option `~A' -- could be any of:~{~% --~A~}" (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 @@ -700,7 +704,7 @@ Ambiguous long option `~A' -- could be any of:~{~% --~A~}" 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. @@ -771,8 +775,7 @@ Ambiguous long option `~A' -- could be any of:~{~% --~A~}" (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) @@ -839,24 +842,19 @@ Ambiguous long option `~A' -- could be any of:~{~% --~A~}" (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))) @@ -871,7 +869,6 @@ Ambiguous long option `~A' -- could be any of:~{~% --~A~}" (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)) @@ -881,9 +878,21 @@ Ambiguous long option `~A' -- could be any of:~{~% --~A~}" (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. @@ -925,6 +934,7 @@ Ambiguous long option `~A' -- could be any of:~{~% --~A~}" (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))