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