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