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