--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Option parser, standard issue
+;;;
+;;; (c) 2005 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble 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
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; SOD 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 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))
+
+(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* "<unknown>"
+ "Program name, as retrieved from the command line.")
+(defvar *command-line* nil
+ "A list of command-line arguments, including the program name.")
+
+(export 'set-command-line-arguments)
+(defun set-command-line-arguments ()
+ "Retrieve command-line arguments.
+
+ Set `*command-line*' and `*program-name*'."
+
+ (setf *command-line*
+ (or (when (member :cl-launch *features*)
+ (let* ((cllpkg (find-package :cl-launch))
+ (name (funcall (intern "GETENV" cllpkg)
+ "CL_LAUNCH_FILE"))
+ (args (symbol-value (intern "*ARGUMENTS*" cllpkg))))
+ (if name
+ (cons name args)
+ args)))
+ #+sbcl sb-ext:*posix-argv*
+ #+cmu ext:*command-line-strings*
+ #+clisp (loop with argv = (ext:argv)
+ for i from 7 below (length argv)
+ collect (aref argv i))
+ #+ecl (loop from i below (ext:argc) collect (ext:argv i))
+ '("<unknown-script>"))
+
+ *program-name* (pathname-name (car *command-line*))))
+
+;;;--------------------------------------------------------------------------
+;;; Fancy conditionals.
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun do-case2-like (kind vform clauses)
+ "Helper function for `case2' and `ecase2'."
+ (with-gensyms (scrutinee argument)
+ `(multiple-value-bind (,scrutinee ,argument) ,vform
+ (declare (ignorable ,argument))
+ (,kind ,scrutinee
+ ,@(mapcar (lambda (clause)
+ (destructuring-bind
+ (cases (&optional varx vary) &rest forms)
+ clause
+ `(,cases
+ ,@(if varx
+ (list `(let ((,(or vary varx) ,argument)
+ ,@(and vary
+ `((,varx ,scrutinee))))
+ ,@forms))
+ forms))))
+ clauses))))))
+
+(defmacro case2 (vform &body clauses)
+ "Switch based on the first value of a form, capturing the second value.
+
+ VFORM is a form which evaluates to two values, SCRUTINEE and ARGUMENT.
+ The CLAUSES have the form (CASES ([[SCRUVAR] ARGVAR]) FORMS...), where a
+ standard `case' clause has the form (CASES FORMS...). The `case2' form
+ evaluates the VFORM, and compares the SCRUTINEE to the various CASES, in
+ order, just like `case'. If there is a match, then the corresponding
+ FORMs are evaluated with ARGVAR bound to the ARGUMENT and SCRUVAR bound to
+ the SCRUTINEE (where specified). Note the bizarre defaulting behaviour:
+ ARGVAR is less optional than SCRUVAR."
+ (do-case2-like 'case vform clauses))
+
+(defmacro ecase2 (vform &body clauses)
+ "Like `case2', but signals an error if no clause matches the SCRUTINEE."
+ (do-case2-like 'ecase vform clauses))
+
+;;;--------------------------------------------------------------------------
+;;; Locatives.
+
+(export '(loc locp))
+(defstruct (loc (:predicate locp) (:constructor make-loc (reader writer)))
+ "Locative data type. See `locf' and `ref'."
+ (reader nil :type function)
+ (writer nil :type function))
+
+(export 'locf)
+(defmacro locf (place &environment env)
+ "Slightly cheesy locatives.
+
+ (locf PLACE) returns an object which, using the `ref' function, can be
+ used to read or set the value of PLACE. It's cheesy because it uses
+ closures rather than actually taking the address of something. Also,
+ unlike Zetalisp, we don't overload `car' to do our dirty work."
+ (multiple-value-bind
+ (valtmps valforms newtmps setform getform)
+ (get-setf-expansion place env)
+ `(let* (,@(mapcar #'list valtmps valforms))
+ (make-loc (lambda () ,getform)
+ (lambda (,@newtmps) ,setform)))))
+
+(export 'ref)
+(declaim (inline ref (setf ref)))
+(defun ref (loc)
+ "Fetch the value referred to by a locative."
+ (funcall (loc-reader loc)))
+(defun (setf ref) (new loc)
+ "Store a new value in the place referred to by a locative."
+ (funcall (loc-writer loc) new))
+
+(export 'with-locatives)
+(defmacro with-locatives (locs &body body)
+ "Evaluate BODY with implicit locatives.
+
+ LOCS is a list of items of the form (SYM [LOC-EXPR]), where SYM is a
+ symbol and LOC-EXPR evaluates to a locative. If LOC-EXPR is omitted, it
+ defaults to SYM. As an abbreviation for a common case, LOCS may be a
+ symbol instead of a list.
+
+ The BODY is evaluated in an environment where each SYM is a symbol macro
+ which expands to (ref LOC-EXPR) -- or, in fact, something similar which
+ doesn't break if LOC-EXPR has side-effects. Thus, references, including
+ `setf' forms, fetch or modify the thing referred to by the LOC-EXPR.
+ Useful for covering over where something uses a locative."
+ (setf locs (mapcar (lambda (item)
+ (cond ((atom item) (list item item))
+ ((null (cdr item)) (list (car item) (car item)))
+ (t item)))
+ (if (listp locs) locs (list locs))))
+ (let ((tt (mapcar (lambda (l) (declare (ignore l)) (gensym)) locs))
+ (ll (mapcar #'cadr locs))
+ (ss (mapcar #'car locs)))
+ `(let (,@(mapcar (lambda (tmp loc) `(,tmp ,loc)) tt ll))
+ (symbol-macrolet (,@(mapcar (lambda (sym tmp)
+ `(,sym (ref ,tmp))) ss tt))
+ ,@body))))
+
+;;;--------------------------------------------------------------------------
+;;; Standard error-reporting functions.
+
+(export 'moan)
+(defun moan (msg &rest args)
+ "Report an error message in the usual way."
+ (format *error-output* "~&~A: ~?~%" *program-name* msg args))
+
+(export 'die)
+(defun die (&rest args)
+ "Report an error message and exit."
+ (apply #'moan args)
+ (exit 1))
+
+;;;--------------------------------------------------------------------------
+;;; The main option parser.
+
+(export '*options*)
+(defvar *options* nil
+ "The default list of command-line options.")
+
+(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:
+
+ 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)))
+
+(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))
+(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*.
+
+ 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))
+
+(export 'option-parse-error)
+(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)))
+
+(export 'option-parse-remainder)
+(defun option-parse-remainder (op)
+ "Returns the unparsed remainder of the command line."
+ (cdr (op-args op)))
+
+(export 'option-parse-return)
+(defun option-parse-return (tag &optional argument)
+ "Force a return from `option-parse-next' with TAG and ARGUMENT.
+
+ This should only be called from an option handler."
+ (throw 'option-parse-return (values tag argument)))
+
+(export 'option-parse-next)
+(defun option-parse-next (op)
+ "Parse and handle the next option from the command-line.
+
+ 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
+ `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
+ this.)
+
+ 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."
+ (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
+ #.(concatenate 'string
+ "Ambiguous long option `~A' -- "
+ "could be any of:"
+ "~{~%~8T--~A~}")
+ optname
+ (mapcar #'opt-long-name matches))))
+ (process-option (car matches)
+ optname
+ negp
+ :arg (and eqpos
+ (subseq arg (1+ eqpos)))))))
+
+ (catch 'option-parse-return
+ (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)))
+ (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))))))))))))))
+
+(export 'option-parse-try)
+(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."
+ (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)))
+
+(export 'with-unix-error-reporting)
+(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)
+ (apply #'die
+ (simple-condition-format-control ,cond)
+ (simple-condition-format-arguments ,cond)))
+ (error (,cond)
+ (die "~A" ,cond)))))
+
+;;;--------------------------------------------------------------------------
+;;; Standard option handlers.
+
+(export 'defopthandler)
+(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))))
+ (multiple-value-bind (docs decls body) (parse-body body)
+ `(progn
+ (setf (get ',name 'opthandler) ',func)
+ (defun ,func (,var ,arg ,@args)
+ ,@docs ,@decls
+ (declare (ignorable ,arg))
+ (with-locatives ,var
+ ,@body))
+ ',name))))
+
+(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."
+ (unless end (setf end (length string)))
+ (labels ((simple (i r goodp sgn)
+ (multiple-value-bind
+ (a i)
+ (if (and (< i end)
+ (digit-char-p (char string i) r))
+ (parse-integer string
+ :start i :end end
+ :radix r
+ :junk-allowed t)
+ (values nil i))
+ (values (if a (* sgn a) (and goodp 0)) i)))
+
+ (get-radix (i r sgn)
+ (cond (r (simple 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 (+ i 2) 16 nil sgn))
+ (#\o (simple (+ i 2) 8 nil sgn))
+ (#\b (simple (+ i 2) 2 nil sgn))
+ (t (simple (1+ i) 8 t sgn))))
+ (t
+ (multiple-value-bind
+ (r i)
+ (simple i 10 nil +1)
+ (cond ((not r) (values nil i))
+ ((and (< i end)
+ (char= (char string i) #\_)
+ (<= 2 r 36))
+ (simple (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)))))
+
+(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."
+ (apply (if (functionp handler) handler
+ (fdefinition (get handler 'opthandler)))
+ loc arg args))
+
+;;;--------------------------------------------------------------------------
+;;; Built-in option handlers.
+
+(export 'set)
+(defopthandler set (var) (&optional (value 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."
+ (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."
+ (incf var step)
+ (when (>= 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."
+ (decf var step)
+ (when (<= var min)
+ (setf var min)))
+
+(export 'read)
+(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)))))
+
+(export 'int)
+(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
+ #.(concatenate 'string
+ "Integer ~A out of range "
+ "(must have ~@[~D <= ~]x~@[ <= ~D~])")
+ arg min max))
+ (setf var v)))
+
+(export 'string)
+(defopthandler string (var arg) ()
+ "Stores ARG in VAR, just as it is."
+ (setf var arg))
+
+(export 'keyword)
+(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)))))))
+
+(export 'list)
+(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))))
+
+;;;--------------------------------------------------------------------------
+;;; Option descriptions.
+
+(export 'defoptmacro)
+(defmacro defoptmacro (name args &body body)
+ "Defines an option macro NAME.
+
+ Option macros should produce a list of expressions producing one option
+ structure each."
+ `(progn
+ (setf (get ',name 'optmacro) (lambda ,args ,@body))
+ ',name))
+
+(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)))))))))
+
+(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:
+
+ STRING A banner to print.
+
+ SYMBOL or (SYMBOL STUFF...)
+ If SYMBOL is an optform macro, the result of invoking it.
+
+ (...) A full option-form. See below.
+
+ Full option-forms are a list of the following kinds of items.
+
+ (:short-name CHAR)
+ (:long-name STRING)
+ (:arg STRING)
+ (:tag TAG)
+ (:negated-tag TAG)
+ (:doc STRING)
+ Set the appropriate slot of the option to the given value.
+ The argument is evaluated.
+
+ (:doc FORMAT-CONTROL ARGUMENTS...)
+ As for (:doc (format nil FORMAT-CONTROL ARGUMENTS...)).
+
+ KEYWORD, (function ...), (lambda ...)
+ 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 If no SHORT-NAME, then the SHORT-NAME.
+
+ STRING or (STRING STUFF...)
+ If no DOCUMENTATION set yet, then the DOCUMENTATION string,
+ as for (:doc STRING STUFF...)
+
+ (: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 ,@(mapcan (lambda (form)
+ (multiple-value-bind
+ (sym args)
+ (cond ((symbolp form) (values form nil))
+ ((and (consp form) (symbolp (car form)))
+ (values (car form) (cdr form)))
+ (t (values nil nil)))
+ (let ((macro (and sym (get sym 'optmacro))))
+ (if macro
+ (apply macro args)
+ (list (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))))))
+
+(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."
+ (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)))
+ (if (listp mandatory-args)
+ mandatory-args
+ (list mandatory-args))))))
+
+(export 'show-usage)
+(defun show-usage (prog usage &optional (stream *standard-output*))
+ "Basic usage-showing function.
+
+ PROG is the program name, probably from `*program-name*'. 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 (if (listp usage) usage (list usage)))
+ (pprint-logical-block (stream nil
+ :prefix (concatenate 'string prog " "))
+ (format stream "~{~A~^ ~:_~}" (if (listp u) u (list u))))))
+ (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)))
+ (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 " ")
+ (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)
+ (pprint-indent :block 30 stream)
+ (print-text doc stream))
+ (terpri stream)))))))
+
+(export 'show-help)
+(defun show-help (prog ver usage opts &optional (stream *standard-output*))
+ "Basic help-showing function.
+
+ PROG is the program name, probably from `*program-name*'. 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))
+
+(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."
+ (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)))
+
+;;;--------------------------------------------------------------------------
+;;; Full program descriptions.
+
+(defvar *help* nil "Help text describing the program.")
+(defvar *version* "<unreleased>" "The program's version number.")
+(defvar *usage* nil "A usage summary string")
+
+(export 'do-usage)
+(defun do-usage (&optional (stream *standard-output*))
+ (show-usage *program-name* *usage* stream))
+
+(export 'die-usage)
+(defun die-usage ()
+ (do-usage *error-output*)
+ (exit 1))
+
+(defun opt-help (arg)
+ (declare (ignore arg))
+ (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))
+(defun opt-version (arg)
+ (declare (ignore arg))
+ (format t "~A, version ~A~%" *program-name* *version*)
+ (exit 0))
+(defun opt-usage (arg)
+ (declare (ignore arg))
+ (do-usage)
+ (exit 0))
+
+(export 'help-options)
+(defoptmacro help-options (&key (short-help #\h)
+ (short-version #\v)
+ (short-usage #\u))
+ "Inserts a standard help options collection in an options list."
+ (flet ((shortform (char)
+ (and char (list char))))
+ (mapcar
+ #'parse-option-form
+ `("Help options"
+ (,@(shortform short-help) "help" #'opt-help
+ "Show this help message.")
+ (,@(shortform short-version) "version" #'opt-version
+ ("Show ~A's version number." *program-name*))
+ (,@(shortform short-usage) "usage" #'opt-usage
+ ("Show a very brief usage summary for ~A." *program-name*))))))
+
+(export 'define-program)
+(defun define-program (&key
+ (program-name nil progp)
+ (help nil helpp)
+ (version nil versionp)
+ (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."
+ (when progp (setf *program-name* program-name))
+ (when helpp (setf *help* help))
+ (when versionp (setf *version* version))
+ (when optsp (setf *options* options))
+ (cond ((and usagep fullp) (error "conflicting options"))
+ (usagep (setf *usage* (simple-usage *options* usage)))
+ (fullp (setf *usage* full-usage))))
+
+(export 'do-options)
+(defmacro do-options ((&key (parser '(make-option-parser)))
+ &body clauses)
+ "Handy all-in-one options parser macro.
+
+ PARSER defaults to a new options parser using the preset default options
+ structure. The CLAUSES are `case2'-like clauses to match options, and
+ must be exhaustive. If there is a clause (nil (REST) FORMS...) then the
+ FORMS are evaluated after parsing is done with REST bound to the remaining
+ command-line arguments."
+ (once-only (parser)
+ `(progn
+ (loop
+ (,(if (find t clauses :key #'car) 'case2 'ecase2)
+ (option-parse-next ,parser)
+ ((nil) () (return))
+ ,@(remove-if #'null clauses :key #'car)))
+ ,@(let ((tail (find nil clauses :key #'car)))
+ (and tail
+ (destructuring-bind ((&optional arg) &rest forms) (cdr tail)
+ (if arg
+ (list `(let ((,arg (option-parse-remainder ,parser)))
+ ,@forms))
+ forms)))))))
+
+;;;----- That's all, folks --------------------------------------------------
~mdw / sod / commitdiff