mdw@git.distorted.org.uk Git - lisp/blob - optparse.lisp

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