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