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

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