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