+;;;--------------------------------------------------------------------------
+;;; Full program descriptions.
+
+(defvar *help*)
+(defvar *version*)
+(defvar *usage*)
+
+(defun opt-help (arg)
+ (declare (ignore arg))
+ (show-help *program-name* *version* *usage* *options*)
+ (typecase *help*
+ (string (terpri) (write-string *help*))
+ ((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 do-usage (&optional (stream *standard-output*))
+ (show-usage *program-name* *usage* stream))
+
+(defun die-usage ()
+ (do-usage *error-output*)
+ (exit 1))
+
+(defun opt-usage (arg)
+ (declare (ignore arg))
+ (do-usage)
+ (exit 0))
+
+(defoptmacro help-opts (&key (short-help #\h)
+ (short-version #\v)
+ (short-usage #\u))
+ (mapcar #'parse-option-form
+ `("Help options"
+ (,@(and short-help (list short-help))
+ "help"
+ #'opt-help
+ "Show this help message.")
+ (,@(and short-version (list short-version))
+ "version"
+ #'opt-version
+ ("Show ~A's version number." *program-name*))
+ (,@(and short-usage (list short-usage))
+ "usage"
+ #'opt-usage
+ ("Show a very brief usage summary for ~A." *program-name*)))))
+
+(defun define-program (&key
+ program-name
+ help
+ version
+ usage full-usage
+ options)
+ "Sets up all the required things a program needs to have to parse options
+and respond to them properly."
+ (when program-name (setf *program-name* program-name))
+ (when help (setf *help* help))
+ (when version (setf *version* version))
+ (when options (setf *options* options))
+ (cond ((and usage full-usage) (error "conflicting options"))
+ (usage (setf *usage* (simple-usage *options* usage)))
+ (full-usage (setf *usage* full-usage))))
+
+(defmacro do-options ((&key (parser '(make-option-parser))) &body clauses)
+ (with-gensyms (topt targ tparser)
+ (flet ((frob (clause)
+ (destructuring-bind
+ (case (&optional arg) &rest forms)
+ clause
+ (and case
+ (list `(,case ,@(if arg
+ `(let ((,arg ,targ)) ,@forms)
+ forms)))))))
+ `(let ((,tparser ,parser))
+ (loop
+ (multiple-value-bind (,topt ,targ) (option-parse-next ,tparser)
+ (declare (ignorable ,targ))
+ (unless ,topt (return))
+ (case ,topt
+ ,@(mapcan #'frob clauses))))
+ ,@(let ((tail (find nil clauses :key #'car)))
+ (and tail
+ (destructuring-bind
+ ((&optional arg) &rest forms)
+ (cdr tail)
+ (list (if arg
+ `(let ((,arg (option-parse-remainder
+ ,tparser)))
+ ,@forms)
+ forms)))))))))
+