chiark - git - mdw - lisp/blob - optparse.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; $Id$
   4 ;;;
   5 ;;; Option parser, standard issue
   6 ;;;
   7 ;;; (c) 2005 Straylight/Edgeware
   8 ;;;
   9
  10 ;;;----- Licensing notice ---------------------------------------------------
  11 ;;;
  12 ;;; This program is free software; you can redistribute it and/or modify
  13 ;;; it under the terms of the GNU General Public License as published by
  14 ;;; the Free Software Foundation; either version 2 of the License, or
  15 ;;; (at your option) any later version.
  16 ;;;
  17 ;;; This program is distributed in the hope that it will be useful,
  18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;;; GNU General Public License for more details.
  21 ;;;
  22 ;;; You should have received a copy of the GNU General Public License
  23 ;;; along with this program; if not, write to the Free Software Foundation,
  24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  25
  26 ;;;--------------------------------------------------------------------------
  27 ;;; Packages.
  28
  29 (defpackage #:optparse
  30   (:use #:common-lisp #:mdw.base #:mdw.sys-base #:mdw.str)
  31   (:export #:exit #:*program-name* #:*command-line-strings*
  32            #:moan #:die
  33            #:option #:optionp #:make-option
  34              #:opt-short-name #:opt-long-name #:opt-tag #:opt-negated-tag
  35              #:opt-arg-name #:opt-arg-optional-p #:opt-documentation
  36            #:option-parser #:make-option-parser #:option-parser-p
  37              #:op-options #:op-non-option #:op-long-only-p #:op-numeric-p
  38              #:op-negated-numeric-p #:op-negated-p
  39            #:option-parse-error
  40            #:option-parse-remainder #:option-parse-next #:option-parse-try
  41              #:with-unix-error-reporting
  42            #:defopthandler #:invoke-option-handler
  43              #:set #:clear #:inc #:dec #:read #:int #:string
  44              #:keyword #:list
  45            #:parse-option-form #:options
  46            #:simple-usage #:show-usage #:show-version #:show-help
  47            #:sanity-check-option-list
  48            #:*help* #:*version* #:*usage* #:*options*
  49            #:do-options #:help-opts #:define-program #:do-usage #:die-usage))
  50
  51 (in-package #:optparse)
  52
  53 ;;;--------------------------------------------------------------------------
  54 ;;; Standard error-reporting functions.
  55
  56 (defun moan (msg &rest args)
  57   "Report an error message in the usual way."
  58   (format *error-output* "~&~A: ~?~%" *program-name* msg args))
  59
  60 (defun die (&rest args)
  61   "Report an error message and exit."
  62   (apply #'moan args)
  63   (exit 1))
  64
  65 ;;;--------------------------------------------------------------------------
  66 ;;; The main option parser.
  67
  68 (defvar *options*)
  69
  70 (defstruct (option (:predicate optionp)
  71                    (:conc-name opt-)
  72                    (:print-function
  73                     (lambda (o s k)
  74                       (declare (ignore k))
  75                       (format s
  76            "#<option~@[ -~C,~]~@[ --~A~]~:[~2*~;~:[=~A~;[=~A]~]~]~@[ ~S~]>"
  77                               (opt-short-name o)
  78                               (opt-long-name o)
  79                               (opt-arg-name o)
  80                               (opt-arg-optional-p o)
  81                               (opt-arg-name o)
  82                               (opt-documentation o))))
  83                    (:constructor %make-option)
  84                    (:constructor make-option
  85                                  (long-name
  86                                   short-name
  87                                   &optional
  88                                   arg-name
  89                                   &key
  90                                   (tag (intern (string-upcase long-name)
  91                                                :keyword))
  92                                   negated-tag
  93                                   arg-optional-p
  94                                   doc
  95                                   (documentation doc))))
  96   "Describes a command-line option.  Slots:
  97
  98    LONG-NAME    The option's long name.  If this is null, the `option' is
  99                 just a banner to be printed in the program's help text.
 100
 101    TAG          The value to be returned if this option is encountered.  If
 102                 this is a function, instead, the function is called with the
 103                 option's argument or nil.
 104
 105    NEGATED-TAG  As for TAG, but used if the negated form of the option is
 106                 found.  If this is nil (the default), the option cannot be
 107                 negated.
 108
 109    SHORT-NAME   The option's short name.  This must be a single character, or
 110                 nil if the option has no short name.
 111
 112    ARG-NAME     The name of the option's argument, a string.  If this is nil,
 113                 the option doesn't accept an argument.  The name is shown in
 114                 the help text.
 115
 116    ARG-OPTIONAL-P
 117                 If non-nil, the option's argument is optional.  This is
 118                 ignored unless ARG-NAME is non-null.
 119
 120    DOCUMENTATION
 121                 The help text for this option.  It is automatically line-
 122                 wrapped.  If nil, the option is omitted from the help
 123                 text.
 124
 125    Usually, one won't use make-option, but use the option macro instead."
 126   (long-name nil :type (or null string))
 127   (tag nil :type t)
 128   (negated-tag nil :type t)
 129   (short-name nil :type (or null character))
 130   (arg-name nil :type (or null string))
 131   (arg-optional-p nil :type t)
 132   (documentation nil :type (or null string)))
 133
 134 (defstruct (option-parser (:conc-name op-)
 135                           (:constructor make-option-parser
 136                                         (&key
 137                                          ((:args argstmp)
 138                                           (cdr *command-line-strings*))
 139                                          (options *options*)
 140                                          (non-option :skip)
 141                                          ((:numericp numeric-p))
 142                                          negated-numeric-p
 143                                          long-only-p
 144                                          &aux
 145                                          (args (cons nil argstmp))
 146                                          (next args)
 147                                          (negated-p (or negated-numeric-p
 148                                                         (some
 149                                                          #'opt-negated-tag
 150                                                          options))))))
 151   "An option parser object.  Slots:
 152
 153    ARGS         The arguments to be parsed.  Usually this will be
 154                 *command-line-strings*.
 155
 156    OPTIONS      List of option structures describing the acceptable options.
 157
 158    NON-OPTION   Behaviour when encountering a non-option argument.  The
 159                 default is :skip.  Allowable values are:
 160                   :skip -- pretend that it appeared after the option
 161                     arguments; this is the default behaviour of GNU getopt
 162                   :stop -- stop parsing options, leaving the remaining
 163                     command line unparsed
 164                   :return -- return :non-option and the argument word
 165
 166    NUMERIC-P    Non-nil tag (as for options) if numeric options (e.g., -43)
 167                 are to be allowed.  The default is nil.  (Anomaly: the
 168                 keyword for this argument is :numericp.)
 169
 170    NEGATED-NUMERIC-P
 171                 Non-nil tag (as for options) if numeric options (e.g., -43)
 172                 can be negated.  This is not the same thing as a negative
 173                 numeric option!
 174
 175    LONG-ONLY-P  A misnomer inherited from GNU getopt.  Whether to allow
 176                 long options to begin with a single dash.  Short options are
 177                 still allowed, and may be cuddled as usual.  The default is
 178                 nil."
 179   (args nil :type list)
 180   (options nil :type list)
 181   (non-option :skip :type (or function (member :skip :stop :return)))
 182   (next nil :type list)
 183   (short-opt nil :type (or null string))
 184   (short-opt-index 0 :type fixnum)
 185   (short-opt-neg-p nil :type t)
 186   (long-only-p nil :type t)
 187   (numeric-p nil :type t)
 188   (negated-numeric-p nil :type t)
 189   (negated-p nil :type t))
 190
 191 (define-condition option-parse-error (error simple-condition)
 192   ()
 193   (:documentation
 194    "Indicates an error found while parsing options.  Probably not that
 195    useful."))
 196
 197 (defun option-parse-error (msg &rest args)
 198   "Signal an option-parse-error with the given message and arguments."
 199   (error (make-condition 'option-parse-error
 200                          :format-control msg
 201                          :format-arguments args)))
 202
 203 (defun option-parse-remainder (op)
 204   "Returns the unparsed remainder of the command line."
 205   (cdr (op-args op)))
 206
 207 (defun option-parse-next (op)
 208   "The main option-parsing function.  OP is an option-parser object,
 209    initialized appropriately.  Returns two values, OPT and ARG: OPT is the
 210    tag of the next option read, and ARG is the argument attached to it, or
 211    nil if there was no argument.  If there are no more options, returns nil
 212    twice.  Options whose TAG is a function aren't returned; instead, the tag
 213    function is called, with the option argument (or nil) as the only
 214    argument.  It is safe for tag functions to throw out of option-parse-next,
 215    if they desparately need to.  (This is the only way to actually get
 216    option-parse-next to return a function value, should that be what you
 217    want.)
 218
 219    While option-parse-next is running, there is a restart `skip-option' which
 220    moves on to the next option.  Error handlers should use this to resume
 221    after parsing errors."
 222   (loop
 223      (labels ((ret (opt &optional arg)
 224                 (return-from option-parse-next (values opt arg)))
 225               (finished ()
 226                 (setf (op-next op) nil)
 227                 (ret nil nil))
 228               (peek-arg ()
 229                 (cadr (op-next op)))
 230               (more-args-p ()
 231                 (and (op-next op)
 232                      (cdr (op-next op))))
 233               (skip-arg ()
 234                 (setf (op-next op) (cdr (op-next op))))
 235               (eat-arg ()
 236                 (setf (cdr (op-next op)) (cddr (op-next op))))
 237               (get-arg ()
 238                 (prog1 (peek-arg) (eat-arg)))
 239               (process-option (o name negp &key arg argfunc)
 240                 (cond ((not (opt-arg-name o))
 241                        (when arg
 242                          (option-parse-error
 243                           "Option `~A' does not accept arguments"
 244                           name)))
 245                       (arg)
 246                       (argfunc
 247                        (setf arg (funcall argfunc)))
 248                       ((opt-arg-optional-p o))
 249                       ((more-args-p)
 250                        (setf arg (get-arg)))
 251                       (t
 252                        (option-parse-error "Option `~A' requires an argument"
 253                                            name)))
 254                 (let ((how (if negp (opt-negated-tag o) (opt-tag o))))
 255                   (if (functionp how)
 256                       (funcall how arg)
 257                       (ret how arg))))
 258               (process-long-option (arg start negp)
 259                 (when (and (not negp)
 260                            (op-negated-p op)
 261                            (> (length arg) (+ start 3))
 262                            (string= arg "no-"
 263                                     :start1 start :end1 (+ start 3)))
 264                   (incf start 3)
 265                   (setf negp t))
 266                 (let* ((matches nil)
 267                        (eqpos (position #\= arg :start start))
 268                        (len (or eqpos (length arg)))
 269                        (optname (subseq arg 0 len))
 270                        (len-2 (- len start)))
 271                   (dolist (o (op-options op))
 272                     (cond ((or (not (stringp (opt-long-name o)))
 273                                (and negp (not (opt-negated-tag o)))
 274                                (< (length (opt-long-name o)) len-2)
 275                                (string/= optname (opt-long-name o)
 276                                          :start1 start :end2 len-2)))
 277                           ((= (length (opt-long-name o)) len-2)
 278                            (setf matches (list o))
 279                            (return))
 280                           (t
 281                            (push o matches))))
 282                   (cond ((null matches)
 283                          (option-parse-error "Unknown option `~A'" optname))
 284                         ((cdr matches)
 285                          (option-parse-error
 286                           "~
 287 Ambiguous long option `~A' -- could be any of:~{~%  --~A~}"
 288                           optname
 289                           (mapcar #'opt-long-name matches))))
 290                   (process-option (car matches)
 291                                   optname
 292                                   negp
 293                                   :arg (and eqpos
 294                                             (subseq arg (1+ eqpos)))))))
 295        (with-simple-restart (skip-option "Skip this bogus option.")
 296          (cond
 297            ;;
 298            ;; We're embroiled in short options: handle them.
 299            ((op-short-opt op)
 300             (if (>= (op-short-opt-index op) (length (op-short-opt op)))
 301                 (setf (op-short-opt op) nil)
 302                 (let* ((str (op-short-opt op))
 303                        (i (op-short-opt-index op))
 304                        (ch (char str i))
 305                        (negp (op-short-opt-neg-p op))
 306                        (name (format nil "~C~A" (if negp #\+ #\-) ch))
 307                        (o (find ch (op-options op) :key #'opt-short-name)))
 308                   (incf i)
 309                   (setf (op-short-opt-index op) i)
 310                   (when (or (not o)
 311                             (and negp (not (opt-negated-tag o))))
 312                     (option-parse-error "Unknown option `~A'" name))
 313                   (process-option o
 314                                   name
 315                                   negp
 316                                   :argfunc
 317                                   (and (< i (length str))
 318                                        (lambda ()
 319                                          (prog1
 320                                              (subseq str i)
 321                                            (setf (op-short-opt op)
 322                                                  nil))))))))
 323            ;;
 324            ;; End of the list.  Say we've finished.
 325            ((not (more-args-p))
 326             (finished))
 327            ;;
 328            ;; Process the next option.
 329            (t
 330             (let ((arg (peek-arg)))
 331               (cond
 332                 ;;
 333                 ;; Non-option.  Decide what to do.
 334                 ((or (<= (length arg) 1)
 335                      (and (char/= (char arg 0) #\-)
 336                           (or (char/= (char arg 0) #\+)
 337                               (not (op-negated-p op)))))
 338                  (case (op-non-option op)
 339                    (:skip (skip-arg))
 340                    (:stop (finished))
 341                    (:return (eat-arg)
 342                             (ret :non-option arg))
 343                    (t (eat-arg)
 344                       (funcall (op-non-option op) arg))))
 345                 ;;
 346                 ;; Double-hyphen.  Stop right now.
 347                 ((string= arg "--")
 348                  (eat-arg)
 349                  (finished))
 350                 ;;
 351                 ;; Numbers.  Check these before long options, since `--43' is
 352                 ;; not a long option.
 353                 ((and (op-numeric-p op)
 354                       (or (char= (char arg 0) #\-)
 355                           (op-negated-numeric-p op))
 356                       (or (and (digit-char-p (char arg 1))
 357                                (every #'digit-char-p (subseq arg 2)))
 358                           (and (or (char= (char arg 1) #\-)
 359                                    (char= (char arg 1) #\+))
 360                                (>= (length arg) 3)
 361                                (digit-char-p (char arg 2))
 362                                (every #'digit-char-p (subseq arg 3)))))
 363                  (eat-arg)
 364                  (let ((negp (char= (char arg 0) #\+))
 365                        (num (parse-integer arg :start 1)))
 366                    (when (and negp (eq (op-negated-numeric-p op) :-))
 367                      (setf num (- num))
 368                      (setf negp nil))
 369                    (let ((how (if negp
 370                                   (op-negated-numeric-p op)
 371                                   (op-numeric-p op))))
 372                      (if (functionp how)
 373                          (funcall how num)
 374                          (ret (if negp :negated-numeric :numeric) num)))))
 375                 ;;
 376                 ;; Long option.  Find the matching option-spec and process
 377                 ;; it.
 378                 ((and (char= (char arg 0) #\-)
 379                       (char= (char arg 1) #\-))
 380                  (eat-arg)
 381                  (process-long-option arg 2 nil))
 382                 ;;
 383                 ;; Short options.  All that's left.
 384                 (t
 385                  (eat-arg)
 386                  (let ((negp (char= (char arg 0) #\+))
 387                        (ch (char arg 1)))
 388                    (cond ((and (op-long-only-p op)
 389                                (not (member ch (op-options op)
 390                                             :key #'opt-short-name)))
 391                           (process-long-option arg 1 negp))
 392                          (t
 393                           (setf (op-short-opt op) arg
 394                                 (op-short-opt-index op) 1
 395                                 (op-short-opt-neg-p op) negp)))))))))))))
 396
 397 (defmacro option-parse-try (&body body)
 398   "Report errors encountered while parsing options, and continue struggling
 399    along.  Also establishes a restart `stop-parsing'.  Returns t if parsing
 400    completed successfully, or nil if errors occurred."
 401   (with-gensyms (retcode)
 402     `(let ((,retcode t))
 403        (restart-case
 404            (handler-bind
 405                ((option-parse-error
 406                  (lambda (cond)
 407                    (setf ,retcode nil)
 408                    (moan "~A" cond)
 409                    (dolist (rn '(skip-option stop-parsing))
 410                      (let ((r (find-restart rn)))
 411                        (when r (invoke-restart r)))))))
 412              ,@body)
 413          (stop-parsing ()
 414            :report "Give up parsing options."
 415            (setf ,retcode nil)))
 416        ,retcode)))
 417
 418 (defmacro with-unix-error-reporting ((&key) &body body)
 419   "Evaluate BODY with errors reported in the standard Unix fashion."
 420   (with-gensyms (cond)
 421     `(handler-case
 422          (progn ,@body)
 423        (simple-condition (,cond)
 424          (apply #'die
 425                 (simple-condition-format-control ,cond)
 426                 (simple-condition-format-arguments ,cond)))
 427        (error (,cond)
 428          (die "~A" ,cond)))))
 429
 430 ;;;--------------------------------------------------------------------------
 431 ;;; Standard option handlers.
 432
 433 (defmacro defopthandler (name (var &optional (arg (gensym)))
 434                          (&rest args)
 435                          &body body)
 436   "Define an option handler function NAME.  Option handlers update a
 437    generalized variable, which may be referred to as VAR in the BODY, based
 438    on some parameters (the ARGS) and the value of an option-argument named
 439    ARG."
 440   (let ((func (intern (format nil "OPTHANDLER/~:@(~A~)" name))))
 441     `(progn
 442        (setf (get ',name 'opthandler) ',func)
 443        (defun ,func (,var ,arg ,@args)
 444          (with-locatives ,var
 445            (declare (ignorable ,arg))
 446            ,@body))
 447       ',name)))
 448
 449 (defun parse-c-integer (string &key radix (start 0) end)
 450   "Parse STRING, or at least the parts of it between START and END, according
 451    to the standard C rules.  Well, almost: the 0 and 0x prefixes are
 452    accepted, but so too are 0o (Haskell) and 0b (original); also RADIX_DIGITS
 453    is accepted, for any radix between 2 and 36.  Prefixes are only accepted
 454    if RADIX is nil.  Returns two values: the integer parsed (or nil if there
 455    wasn't enough for a sensible parse), and the index following the
 456    characters of the integer."
 457   (unless end (setf end (length string)))
 458   (labels ((simple (i r goodp sgn)
 459              (multiple-value-bind
 460                  (a i)
 461                  (if (and (< i end)
 462                           (digit-char-p (char string i) r))
 463                      (parse-integer string
 464                                     :start i :end end
 465                                     :radix r
 466                                     :junk-allowed t)
 467                      (values nil i))
 468                (values (if a (* sgn a) (and goodp 0)) i)))
 469            (get-radix (i r sgn)
 470              (cond (r (simple i r nil sgn))
 471                    ((>= i end) (values nil i))
 472                    ((and (char= (char string i) #\0)
 473                          (>= (- end i) 2))
 474                     (case (char string (1+ i))
 475                       (#\x (simple (+ i 2) 16 nil sgn))
 476                       (#\o (simple (+ i 2) 8 nil sgn))
 477                       (#\b (simple (+ i 2) 2 nil sgn))
 478                       (t (simple (1+ i) 8 t sgn))))
 479                    (t
 480                     (multiple-value-bind
 481                         (r i)
 482                         (simple i 10 nil +1)
 483                       (cond ((not r) (values nil i))
 484                             ((and (< i end)
 485                                   (char= (char string i) #\_)
 486                                   (<= 2 r 36))
 487                              (simple (1+ i) r nil sgn))
 488                             (t
 489                              (values (* r sgn) i))))))))
 490     (cond ((>= start end) (values nil start))
 491           ((char= (char string start) #\-)
 492            (get-radix (1+ start) radix -1))
 493           ((char= (char string start) #\+)
 494            (get-radix (1+ start) radix +1))
 495           (t
 496            (get-radix start radix +1)))))
 497
 498 (defun invoke-option-handler (handler loc arg args)
 499   "Call the HANDLER function, giving it LOC to update, the option-argument
 500    ARG, and the remaining ARGS."
 501   (apply (if (functionp handler) handler
 502              (fdefinition (get handler 'opthandler)))
 503          loc
 504          arg
 505          args))
 506
 507 ;;;--------------------------------------------------------------------------
 508 ;;; Built-in option handlers.
 509
 510 (defopthandler set (var) (&optional (value t))
 511   "Sets VAR to VALUE; defaults to t."
 512   (setf var value))
 513
 514 (defopthandler clear (var) (&optional (value nil))
 515   "Sets VAR to VALUE; defaults to nil."
 516   (setf var value))
 517
 518 (defopthandler inc (var) (&optional max (step 1))
 519   "Increments VAR by STEP (defaults to 1), but not greater than MAX (default
 520    nil for no maximum).  No errors are signalled."
 521   (incf var step)
 522   (when (>= var max)
 523     (setf var max)))
 524
 525 (defopthandler dec (var) (&optional min (step 1))
 526   "Decrements VAR by STEP (defaults to 1), but not less than MIN (default nil
 527    for no maximum).  No errors are signalled."
 528   (decf var step)
 529   (when (<= var min)
 530     (setf var min)))
 531
 532 (defopthandler read (var arg) ()
 533   "Stores in VAR the Lisp object found by reading the ARG.  Evaluation is
 534    forbidden while reading ARG.  If there is an error during reading, an
 535    error of type option-parse-error is signalled."
 536   (handler-case
 537       (let ((*read-eval* nil))
 538         (multiple-value-bind (x end) (read-from-string arg t)
 539           (unless (>= end (length arg))
 540             (option-parse-error "Junk at end of argument `~A'" arg))
 541           (setf var x)))
 542     (error (cond)
 543       (option-parse-error (format nil "~A" cond)))))
 544
 545 (defopthandler int (var arg) (&key radix min max)
 546   "Stores in VAR the integer read from the ARG.  Integers are parsed
 547    according to C rules, which is normal in Unix; the RADIX may be nil to
 548    allow radix prefixes, or an integer between 2 and 36.  An
 549    option-parse-error is signalled if the ARG is not a valid integer, or if
 550    it is not between MIN and MAX (either of which may be nil if no lower
 551    resp. upper bound is wanted)."
 552   (multiple-value-bind (v end) (parse-c-integer arg :radix radix)
 553     (unless (and v (>= end (length arg)))
 554       (option-parse-error "Bad integer `~A'" arg))
 555     (when (or (and min (< v min))
 556               (and max (> v max)))
 557       (option-parse-error
 558        "Integer ~A out of range (must have ~@[~D <= ~]x~@[ <= ~D~])"
 559        arg min max))
 560     (setf var v)))
 561
 562 (defopthandler string (var arg) ()
 563   "Stores ARG in VAR, just as it is."
 564   (setf var arg))
 565
 566 (defopthandler keyword (var arg) (&rest valid)
 567   (if (null valid)
 568       (setf var (intern (string-upcase arg) :keyword))
 569       (let ((matches nil)
 570             (guess (string-upcase arg))
 571             (len (length arg)))
 572         (dolist (k valid)
 573           (let* ((kn (symbol-name k))
 574                  (klen (length kn)))
 575             (cond ((string= kn guess)
 576                    (setf matches (list k))
 577                    (return))
 578                   ((and (< len klen)
 579                         (string= guess kn :end2 len))
 580                    (push k matches)))))
 581         (case (length matches)
 582           (0 (option-parse-error "Argument `~A' invalid: must be one of:~
 583                                    ~{~%~8T~(~A~)~}"
 584                                  arg valid))
 585           (1 (setf var (car matches)))
 586           (t (option-parse-error "Argument `~A' ambiguous: may be any of:~
 587                                    ~{~%~8T~(~A~)~}"
 588                                  arg matches))))))
 589
 590 (defopthandler list (var arg) (&optional handler &rest handler-args)
 591   "Collect ARGs in a list at VAR.  ARGs are translated by the HANDLER first,
 592    if specified.  If not, it's as if you asked for `string'."
 593   (when handler
 594     (invoke-option-handler handler (locf arg) arg handler-args))
 595   (setf var (nconc var (list arg))))
 596
 597 ;;;--------------------------------------------------------------------------
 598 ;;; Option descriptions.
 599
 600 (defmacro defoptmacro (name args &body body)
 601   "Defines an option macro NAME.  Option macros should produce a list of
 602    expressions producing one option structure each."
 603   `(progn
 604      (setf (get ',name 'optmacro) (lambda ,args ,@body))
 605      ',name))
 606
 607 (compile-time-defun parse-option-form (form)
 608   "Does the heavy lifting for parsing an option form.  See the docstring for
 609    the `option' macro for details of the syntax."
 610   (flet ((doc (form)
 611            (cond ((stringp form) form)
 612                  ((null (cdr form)) (car form))
 613                  (t `(format nil ,@form))))
 614          (docp (form)
 615            (or (stringp form)
 616                (and (consp form)
 617                     (stringp (car form))))))
 618     (cond ((stringp form)
 619            `(%make-option :documentation ,form))
 620           ((not (listp form))
 621            (error "option form must be string or list"))
 622           ((and (docp (car form)) (null (cdr form)))
 623            `(%make-option :documentation ,(doc (car form))))
 624           (t
 625            (let (long-name short-name
 626                  arg-name arg-optional-p
 627                  tag negated-tag
 628                  doc)
 629              (dolist (f form)
 630                (cond ((and (or (not tag) (not negated-tag))
 631                            (or (keywordp f)
 632                                (and (consp f)
 633                                     (member (car f) '(lambda function)))))
 634                       (if tag
 635                           (setf negated-tag f)
 636                           (setf tag f)))
 637                      ((and (not long-name)
 638                            (or (rationalp f)
 639                                (symbolp f)
 640                                (stringp f)))
 641                       (setf long-name (if (stringp f) f
 642                                           (format nil "~(~A~)" f))))
 643                      ((and (not short-name)
 644                            (characterp f))
 645                       (setf short-name f))
 646                      ((and (not doc)
 647                            (docp f))
 648                       (setf doc (doc f)))
 649                      ((and (consp f) (symbolp (car f)))
 650                       (case (car f)
 651                         (:arg (setf arg-name (cadr f)))
 652                         (:opt-arg (setf arg-name (cadr f))
 653                                   (setf arg-optional-p t))
 654                         (:doc (setf doc (doc (cdr f))))
 655                         (t (let ((handler (get (car f) 'opthandler)))
 656                              (unless handler
 657                                (error "No handler `~S' defined." (car f)))
 658                              (let* ((var (cadr f))
 659                                     (arg (gensym))
 660                                     (thunk `#'(lambda (,arg)
 661                                                 (,handler (locf ,var)
 662                                                           ,arg
 663                                                           ,@(cddr f)))))
 664                                (if tag
 665                                    (setf negated-tag thunk)
 666                                    (setf tag thunk)))))))
 667                      (t
 668                       (error "Unexpected thing ~S in option form." f))))
 669              `(make-option ,long-name ,short-name ,arg-name
 670                ,@(and arg-optional-p `(:arg-optional-p t))
 671                ,@(and tag `(:tag ,tag))
 672                ,@(and negated-tag `(:negated-tag ,negated-tag))
 673                ,@(and doc `(:documentation ,doc))))))))
 674
 675 (defmacro options (&rest optlist)
 676   "More convenient way of initializing options.  The OPTLIST is a list of
 677    OPTFORMS.  Each OPTFORM is one of the following:
 678
 679    STRING       A banner to print.
 680
 681    SYMBOL or (SYMBOL STUFF...)
 682                 If SYMBOL is an optform macro, the result of invoking it.
 683
 684    (...)        A full option-form.  See below.
 685
 686    Full option-forms are as follows.
 687
 688    KEYWORD or FUNCTION
 689                 If no TAG is set yet, then as a TAG; otherwise as the
 690                 NEGATED-TAG.
 691
 692    STRING (or SYMBOL or RATIONAL)
 693                 If no LONG-NAME seen yet, then the LONG-NAME.  For symbols
 694                 and rationals, the item is converted to a string and squashed
 695                 to lower-case.
 696
 697    CHARACTER    The SHORT-NAME.
 698
 699    STRING or (STRING STUFF...)
 700                 If no DOCUMENTATION set yet, then the DOCUMENTATION string,
 701                 as for (:DOC STRING STUFF...)
 702
 703    (:DOC STRING STUFF...)
 704                 The DOCUMENATION string.  With no STUFF, STRING is used as
 705                 is;otherwise the documentation string is computed by (format
 706                 nil STRING STUFF...).
 707
 708    (:ARG NAME)  Set the ARG-NAME.
 709
 710    (:OPT-ARG NAME)
 711                 Set the ARG-NAME, and also set ARG-OPTIONAL-P.
 712
 713    (HANDLER VAR ARGS...)
 714                 If no TAG is set yet, attach the HANDLER to this option,
 715                 giving it ARGS.  Otherwise, set the NEGATED-TAG."
 716   `(list ,@(mapcan (lambda (form)
 717                      (multiple-value-bind
 718                          (sym args)
 719                          (cond ((symbolp form) (values form nil))
 720                                ((and (consp form) (symbolp (car form)))
 721                                 (values (car form) (cdr form)))
 722                                (t (values nil nil)))
 723                        (let ((macro (and sym (get sym 'optmacro))))
 724                          (if macro
 725                              (apply macro args)
 726                              (list (parse-option-form form))))))
 727                    optlist)))
 728
 729 ;;;--------------------------------------------------------------------------
 730 ;;; Support stuff for help and usage messages.
 731
 732 (defun print-text (string
 733                    &optional
 734                    (stream *standard-output*)
 735                    &key
 736                    (start 0)
 737                    (end nil))
 738   "Prints STRING to a pretty-printed STREAM, breaking it at whitespace and
 739    newlines in the obvious way.  Stuff between square brackets is not broken:
 740    this makes usage messages work better."
 741   (let ((i start)
 742         (nest 0)
 743         (splitp nil))
 744     (flet ((emit ()
 745              (write-string string stream :start start :end i)
 746              (setf start i)))
 747       (unless end
 748         (setf end (length string)))
 749       (loop
 750          (unless (< i end)
 751            (emit)
 752            (return))
 753          (let ((ch (char string i)))
 754            (cond ((char= ch #\newline)
 755                   (emit)
 756                   (incf start)
 757                   (pprint-newline :mandatory stream))
 758                  ((whitespace-char-p ch)
 759                   (when (zerop nest)
 760                     (setf splitp t)))
 761                  (t
 762                   (when splitp
 763                     (emit)
 764                     (pprint-newline :fill stream))
 765                   (setf splitp nil)
 766                   (case ch
 767                     (#\[ (incf nest))
 768                     (#\] (when (plusp nest) (decf nest))))))
 769            (incf i))))))
 770
 771 (defun simple-usage (opts &optional mandatory-args)
 772   "Build a simple usage list from a list of options, and (optionally)
 773    mandatory argument names."
 774   (let (short-simple long-simple short-arg long-arg)
 775     (dolist (o opts)
 776       (cond ((not (and (opt-documentation o)
 777                        (opt-long-name o))))
 778             ((and (opt-short-name o) (opt-arg-name o))
 779              (push o short-arg))
 780             ((opt-short-name o)
 781              (push o short-simple))
 782             ((opt-arg-name o)
 783              (push o long-arg))
 784             (t
 785              (push o long-simple))))
 786     (list
 787      (nconc (and short-simple
 788                  (list (format nil "[-~{~C~}]"
 789                                (sort (mapcar #'opt-short-name short-simple)
 790                                      #'char<))))
 791             (and long-simple
 792                  (mapcar (lambda (o)
 793                            (format nil "[--~A]" (opt-long-name o)))
 794                          (sort long-simple #'string< :key #'opt-long-name)))
 795             (and short-arg
 796                  (mapcar (lambda (o)
 797                            (format nil "~:[[-~C ~A]~;[-~C[~A]]~]"
 798                                    (opt-arg-optional-p o)
 799                                    (opt-short-name o)
 800                                    (opt-arg-name o)))
 801                          (sort short-arg #'char-lessp
 802                                :key #'opt-short-name)))
 803             (and long-arg
 804                  (mapcar (lambda (o)
 805                            (format nil "~:[[--~A ~A]~;[--~A[=~A]]~]"
 806                                    (opt-arg-optional-p o)
 807                                    (opt-long-name o)
 808                                    (opt-arg-name o)))
 809                          (sort long-arg #'string-lessp
 810                                :key #'opt-long-name)))
 811             (listify mandatory-args)))))
 812
 813 (defun show-usage (prog usage &optional (stream *standard-output*))
 814   "Basic usage-showing function.  PROG is the program name, probably from
 815    *command-line-strings*.  USAGE is a list of possible usages of the
 816    program, each of which is a list of items to be supplied by the user.  In
 817    simple cases, a single string is sufficient."
 818   (pprint-logical-block (stream nil :prefix "Usage: ")
 819     (dolist (u (listify usage))
 820       (pprint-logical-block (stream nil :prefix (format nil "~A " prog))
 821         (format stream "~{~A ~:_~}" (listify u)))
 822       (pprint-newline :mandatory stream))))
 823
 824 (defun show-help (prog ver usage opts &optional (stream *standard-output*))
 825   "Basic help-showing function.  PROG is the program name, probably from
 826    *command-line-strings*.  VER is the program's version number.  USAGE is a
 827    list of the possible usages of the program, each of which may be a list of
 828    items to be supplied.  OPTS is the list of supported options, as provided
 829    to the options parser.  STREAM is the stream to write on."
 830   (format stream "~A, version ~A~2%" prog ver)
 831   (show-usage prog usage stream)
 832   (terpri stream)
 833   (let (newlinep)
 834     (dolist (o opts)
 835       (let ((doc (opt-documentation o)))
 836         (cond ((not o))
 837               ((not (opt-long-name o))
 838                (when newlinep
 839                  (terpri stream)
 840                  (setf newlinep nil))
 841                (pprint-logical-block (stream nil)
 842                  (print-text doc stream))
 843                (terpri stream))
 844               (t
 845                (setf newlinep t)
 846                (pprint-logical-block (stream nil :prefix "  ")
 847                  (pprint-indent :block 30 stream)
 848                  (format stream "~:[   ~;-~:*~C,~] --~A"
 849                          (opt-short-name o)
 850                          (opt-long-name o))
 851                  (when (opt-arg-name o)
 852                    (format stream "~:[=~A~;[=~A]~]"
 853                            (opt-arg-optional-p o)
 854                            (opt-arg-name o)))
 855                  (write-string "  " stream)
 856                  (pprint-tab :line 30 1 stream)
 857                  (print-text doc stream))
 858                (terpri stream)))))))
 859
 860 (defun sanity-check-option-list (opts)
 861   "Check the option list OPTS for basic sanity.  Reused short and long option
 862    names are diagnosed.  Maybe other problems will be reported later.
 863    Returns a list of warning strings."
 864   (let ((problems nil)
 865         (longs (make-hash-table :test #'equal))
 866         (shorts (make-hash-table)))
 867     (flet ((problem (msg &rest args)
 868              (push (apply #'format nil msg args) problems)))
 869       (dolist (o opts)
 870         (push o (gethash (opt-long-name o) longs))
 871         (push o (gethash (opt-short-name o) shorts)))
 872       (maphash (lambda (k v)
 873                  (when (and k (cdr v))
 874                    (problem "Long name `--~A' reused in ~S" k v)))
 875                longs)
 876       (maphash (lambda (k v)
 877                  (when (and k (cdr v))
 878                    (problem "Short name `-~C' reused in ~S" k v)))
 879                shorts)
 880       problems)))
 881
 882 ;;;--------------------------------------------------------------------------
 883 ;;; Full program descriptions.
 884
 885 (defvar *help*)
 886 (defvar *version*)
 887 (defvar *usage*)
 888
 889 (defun opt-help (arg)
 890   (declare (ignore arg))
 891   (show-help *program-name* *version* *usage* *options*)
 892   (typecase *help*
 893     (string (terpri) (write-string *help*))
 894     ((or function symbol) (terpri) (funcall *help*)))
 895   (format t "~&")
 896   (exit 0))
 897
 898 (defun opt-version (arg)
 899   (declare (ignore arg))
 900   (format t "~A, version ~A~%" *program-name* *version*)
 901   (exit 0))
 902
 903 (defun do-usage (&optional (stream *standard-output*))
 904   (show-usage *program-name* *usage* stream))
 905
 906 (defun die-usage ()
 907   (do-usage *error-output*)
 908   (exit 1))
 909
 910 (defun opt-usage (arg)
 911   (declare (ignore arg))
 912   (do-usage)
 913   (exit 0))
 914
 915 (defoptmacro help-opts (&key (short-help #\h)
 916                              (short-version #\v)
 917                              (short-usage #\u))
 918   (mapcar #'parse-option-form
 919           `("Help options"
 920             (,@(and short-help (list short-help))
 921              "help"
 922              #'opt-help
 923              "Show this help message.")
 924             (,@(and short-version (list short-version))
 925              "version"
 926              #'opt-version
 927              ("Show ~A's version number." *program-name*))
 928             (,@(and short-usage (list short-usage))
 929              "usage"
 930              #'opt-usage
 931              ("Show a very brief usage summary for ~A." *program-name*)))))
 932
 933 (defun define-program (&key
 934                        program-name
 935                        help
 936                        version
 937                        usage full-usage
 938                        options)
 939   "Sets up all the required things a program needs to have to parse options
 940    and respond to them properly."
 941   (when program-name (setf *program-name* program-name))
 942   (when help (setf *help* help))
 943   (when version (setf *version* version))
 944   (when options (setf *options* options))
 945   (cond ((and usage full-usage) (error "conflicting options"))
 946         (usage (setf *usage* (simple-usage *options* usage)))
 947         (full-usage (setf *usage* full-usage))))
 948
 949 (defmacro do-options ((&key (parser '(make-option-parser))) &body clauses)
 950   "Handy all-in-one options parser macro.  PARSER defaults to a new options
 951    parser using the preset default options structure.  The CLAUSES are
 952    `case2'-like clauses to match options, and must be exhaustive.  If there
 953    is a clause (nil (REST) FORMS...) then the FORMS are evaluated after
 954    parsing is done with REST bound to the remaining command-line arguments."
 955   (with-gensyms (tparser)
 956     `(let ((,tparser ,parser))
 957        (loop
 958          (,(if (find t clauses :key #'car) 'case2 'ecase2)
 959              (option-parse-next ,tparser)
 960            ((nil) () (return))
 961            ,@(remove-if #'null clauses :key #'car)))
 962        ,@(let ((tail (find nil clauses :key #'car)))
 963            (and tail
 964                 (destructuring-bind ((&optional arg) &rest forms) (cdr tail)
 965                   (if arg
 966                       (list `(let ((,arg (option-parse-remainder ,tparser)))
 967                                ,@forms))
 968                       forms)))))))
 969
 970 ;;;----- That's all, folks --------------------------------------------------