mdw@git.distorted.org.uk Git - lisp/blob - optparse.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; $Id$
   4 ;;;
   5 ;;; Option parser, standard issue
   6 ;;;
   7 ;;; (c) 2005 Straylight/Edgeware
   8 ;;;
   9
  10 ;;;----- Licensing notice ---------------------------------------------------
  11 ;;;
  12 ;;; This program 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 ;;; This program 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 this program; if not, write to the Free Software Foundation,
  24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  25
  26 (defpackage #:mdw.optparse
  27   (:use #:common-lisp #:mdw.base #:mdw.sys-base #:mdw.str)
  28   (:export #:exit #:*program-name* #:*command-line-strings*
  29            #:moan #:die
  30            #:option #:optionp #:make-option
  31              #:opt-short-name #:opt-long-name #:opt-tag #:opt-negated-tag
  32              #:opt-arg-name #:opt-arg-optional-p #:opt-documentation
  33            #:option-parser #:make-option-parser #:option-parser-p
  34              #:op-options #:op-non-option #:op-long-only-p #:op-numeric-p
  35              #:op-negated-numeric-p #:op-negated-p
  36            #:option-parse-error
  37            #:option-parse-remainder #:option-parse-next #:option-parse-try
  38              #:with-unix-error-reporting
  39            #:defopthandler #:invoke-option-handler
  40              #:set #:clear #:inc #:dec #:read #:int #:string
  41              #:keyword #:list
  42            #:parse-option-form #:options
  43            #:simple-usage #:show-usage #:show-version #:show-help
  44            #:sanity-check-option-list))
  45
  46 (in-package #:mdw.optparse)
  47
  48 ;;; Standard error-reporting functions.
  49
  50 (defun moan (msg &rest args)
  51   "Report an error message in the usual way."
  52   (format *error-output* "~&~A: ~?~%" *program-name* msg args))
  53 (defun die (&rest args)
  54   "Report an error message and exit."
  55   (apply #'moan args)
  56   (exit 1))
  57
  58 ;;; The main option parser.
  59
  60 (defstruct (option (:predicate optionp)
  61                    (:conc-name opt-)
  62                    (:print-function
  63                     (lambda (o s k)
  64                       (declare (ignore k))
  65                       (format s
  66            "#<option~@[ -~C,~]~@[ --~A~]~:[~2*~;~:[=~A~;[=~A]~]~]~@[ ~S~]>"
  67                               (opt-short-name o)
  68                               (opt-long-name o)
  69                               (opt-arg-name o)
  70                               (opt-arg-optional-p o)
  71                               (opt-arg-name o)
  72                               (opt-documentation o))))
  73                    (:constructor %make-option)
  74                    (:constructor make-option
  75                                  (long-name
  76                                   short-name
  77                                   &optional
  78                                   arg-name
  79                                   &key
  80                                   (tag (intern (string-upcase long-name)
  81                                                :keyword))
  82                                   negated-tag
  83                                   arg-optional-p
  84                                   doc
  85                                   (documentation doc))))
  86   "Describes a command-line option.  Slots:
  87
  88 LONG-NAME       The option's long name.  If this is null, the `option' is
  89                 just a banner to be printed in the program's help text.
  90
  91 TAG             The value to be returned if this option is encountered.  If
  92                 this is a function, instead, the function is called with the
  93                 option's argument or nil.
  94
  95 NEGATED-TAG     As for TAG, but used if the negated form of the option is
  96                 found.  If this is nil (the default), the option cannot be
  97                 negated.
  98
  99 SHORT-NAME      The option's short name.  This must be a single character, or
 100                 nil if the option has no short name.
 101
 102 ARG-NAME        The name of the option's argument, a string.  If this is nil,
 103                 the option doesn't accept an argument.  The name is shown in
 104                 the help text.
 105
 106 ARG-OPTIONAL-P  If non-nil, the option's argument is optional.  This is
 107                 ignored unless ARG-NAME is non-null.
 108
 109 DOCUMENTATION   The help text for this option.  It is automatically
 110                 line-wrapped.  If nil, the option is omitted from the help
 111                 text.
 112
 113 Usually, one won't use make-option, but use the option macro instead."
 114   (long-name nil :type (or null string))
 115   (tag nil :type t)
 116   (negated-tag nil :type t)
 117   (short-name nil :type (or null character))
 118   (arg-name nil :type (or null string))
 119   (arg-optional-p nil :type t)
 120   (documentation nil :type (or null string)))
 121
 122 (defstruct (option-parser (:conc-name op-)
 123                           (:constructor make-option-parser
 124                                         (argstmp
 125                                          options
 126                                          &key
 127                                          (non-option :skip)
 128                                          ((:numericp numeric-p))
 129                                          negated-numeric-p
 130                                          long-only-p
 131                                          &aux
 132                                          (args (cons nil argstmp))
 133                                          (next args)
 134                                          (negated-p (or negated-numeric-p
 135                                                         (some
 136                                                          #'opt-negated-tag
 137                                                          options))))))
 138   "An option parser object.  Slots:
 139
 140 ARGS            The arguments to be parsed.  Usually this will be
 141                 *command-line-strings*.
 142
 143 OPTIONS         List of option structures describing the acceptable options.
 144
 145 NON-OPTION      Behaviour when encountering a non-option argument.  The
 146                 default is :skip.  Allowable values are:
 147                   :skip -- pretend that it appeared after the option
 148                     arguments; this is the default behaviour of GNU getopt
 149                   :stop -- stop parsing options, leaving the remaining
 150                     command line unparsed
 151                   :return -- return :non-option and the argument word
 152
 153 NUMERIC-P       Non-nil tag (as for options) if numeric options (e.g., -43)
 154                 are to be allowed.  The default is nil.  (Anomaly: the
 155                 keyword for this argument is :numericp.)
 156
 157 NEGATED-NUMERIC-P
 158                 Non-nil tag (as for options) if numeric options (e.g., -43)
 159                 can be negated.  This is not the same thing as a negative
 160                 numeric option!
 161
 162 LONG-ONLY-P     A misnomer inherited from GNU getopt.  Whether to allow
 163                 long options to begin with a single dash.  Short options are
 164                 still allowed, and may be cuddled as usual.  The default is
 165                 nil."
 166   (args nil :type list)
 167   (options nil :type list)
 168   (non-option :skip :type (or function (member :skip :stop :return)))
 169   (next nil :type list)
 170   (short-opt nil :type (or null string))
 171   (short-opt-index 0 :type fixnum)
 172   (short-opt-neg-p nil :type t)
 173   (long-only-p nil :type t)
 174   (numeric-p nil :type t)
 175   (negated-numeric-p nil :type t)
 176   (negated-p nil :type t))
 177
 178 (define-condition option-parse-error (error simple-condition)
 179   ()
 180   (:documentation "Indicates an error found while parsing options.  Probably
 181 not that useful."))
 182
 183 (defun option-parse-error (msg &rest args)
 184   "Signal an option-parse-error with the given message and arguments."
 185   (error (make-condition 'option-parse-error
 186                          :format-control msg
 187                          :format-arguments args)))
 188
 189 (defun option-parse-remainder (op)
 190   "Returns the unparsed remainder of the command line."
 191   (cdr (op-args op)))
 192
 193 (defun option-parse-next (op)
 194   "The main option-parsing function.  OP is an option-parser object,
 195 initialized appropriately.  Returns two values, OPT and ARG: OPT is the tag
 196 of the next option read, and ARG is the argument attached to it, or nil if
 197 there was no argument.  If there are no more options, returns nil twice.
 198 Options whose TAG is a function aren't returned; instead, the tag function is
 199 called, with the option argument (or nil) as the only argument.  It is safe
 200 for tag functions to throw out of option-parse-next, if they desparately need
 201 to.  (This is the only way to actually get option-parse-next to return a
 202 function value, should that be what you want.)
 203
 204 While option-parse-next is running, there is a restart `skip-option' which
 205 moves on to the next option.  Error handlers should use this to resume after
 206 parsing errors."
 207   (loop
 208      (labels ((ret (opt &optional arg)
 209                 (return-from option-parse-next (values opt arg)))
 210               (finished ()
 211                 (setf (op-next op) nil)
 212                 (ret nil nil))
 213               (peek-arg ()
 214                 (cadr (op-next op)))
 215               (more-args-p ()
 216                 (and (op-next op)
 217                      (cdr (op-next op))))
 218               (skip-arg ()
 219                 (setf (op-next op) (cdr (op-next op))))
 220               (eat-arg ()
 221                 (setf (cdr (op-next op)) (cddr (op-next op))))
 222               (get-arg ()
 223                 (prog1 (peek-arg) (eat-arg)))
 224               (process-option (o name negp &key arg argfunc)
 225                 (cond ((not (opt-arg-name o))
 226                        (when arg
 227                          (option-parse-error
 228                           "Option `~A' does not accept arguments"
 229                           name)))
 230                       (arg)
 231                       (argfunc
 232                        (setf arg (funcall argfunc)))
 233                       ((opt-arg-optional-p o))
 234                       ((more-args-p)
 235                        (setf arg (get-arg)))
 236                       (t
 237                        (option-parse-error "Option `~A' requires an argument"
 238                                            name)))
 239                 (let ((how (if negp (opt-negated-tag o) (opt-tag o))))
 240                   (if (functionp how)
 241                       (funcall how arg)
 242                       (ret how arg))))
 243               (process-long-option (arg start negp)
 244                 (when (and (not negp)
 245                            (op-negated-p op)
 246                            (> (length arg) (+ start 3))
 247                            (string= arg "no-"
 248                                     :start1 start :end1 (+ start 3)))
 249                   (incf start 3)
 250                   (setf negp t))
 251                 (let* ((matches nil)
 252                        (eqpos (position #\= arg :start start))
 253                        (len (or eqpos (length arg)))
 254                        (optname (subseq arg 0 len))
 255                        (len-2 (- len start)))
 256                   (dolist (o (op-options op))
 257                     (cond ((or (not (stringp (opt-long-name o)))
 258                                (and negp (not (opt-negated-tag o)))
 259                                (< (length (opt-long-name o)) len-2)
 260                                (string/= optname (opt-long-name o)
 261                                          :start1 start :end2 len-2)))
 262                           ((= (length (opt-long-name o)) len-2)
 263                            (setf matches (list o))
 264                            (return))
 265                           (t
 266                            (push o matches))))
 267                   (cond ((null matches)
 268                          (option-parse-error "Unknown option `~A'" optname))
 269                         ((cdr matches)
 270                          (option-parse-error
 271                           "~
 272 Ambiguous long option `~A' -- could be any of:~{~%  --~A~}"
 273                           optname
 274                           (mapcar #'opt-long-name matches))))
 275                   (process-option (car matches)
 276                                   optname
 277                                   negp
 278                                   :arg (and eqpos
 279                                             (subseq arg (1+ eqpos)))))))
 280        (with-simple-restart (skip-option "Skip this bogus option.")
 281          (cond
 282            ;;
 283            ;; We're embroiled in short options: handle them.
 284            ((op-short-opt op)
 285             (if (>= (op-short-opt-index op) (length (op-short-opt op)))
 286                 (setf (op-short-opt op) nil)
 287                 (let* ((str (op-short-opt op))
 288                        (i (op-short-opt-index op))
 289                        (ch (char str i))
 290                        (negp (op-short-opt-neg-p op))
 291                        (name (format nil "~C~A" (if negp #\+ #\-) ch))
 292                        (o (find ch (op-options op) :key #'opt-short-name)))
 293                   (incf i)
 294                   (setf (op-short-opt-index op) i)
 295                   (when (or (not o)
 296                             (and negp (not (opt-negated-tag o))))
 297                     (option-parse-error "Unknown option `~A'" name))
 298                   (process-option o
 299                                   name
 300                                   negp
 301                                   :argfunc
 302                                   (and (< i (length str))
 303                                        (lambda ()
 304                                          (prog1
 305                                              (subseq str i)
 306                                            (setf (op-short-opt op)
 307                                                  nil))))))))
 308            ;;
 309            ;; End of the list.  Say we've finished.
 310            ((not (more-args-p))
 311             (finished))
 312            ;;
 313            ;; Process the next option.
 314            (t
 315             (let ((arg (peek-arg)))
 316               (cond
 317                 ;;
 318                 ;; Non-option.  Decide what to do.
 319                 ((or (<= (length arg) 1)
 320                      (and (char/= (char arg 0) #\-)
 321                           (or (char/= (char arg 0) #\+)
 322                               (not (op-negated-p op)))))
 323                  (case (op-non-option op)
 324                    (:skip (skip-arg))
 325                    (:stop (finished))
 326                    (:return (eat-arg)
 327                             (ret :non-option arg))
 328                    (t (eat-arg)
 329                       (funcall (op-non-option op) arg))))
 330                 ;;
 331                 ;; Double-hyphen.  Stop right now.
 332                 ((string= arg "--")
 333                  (eat-arg)
 334                  (finished))
 335                 ;;
 336                 ;; Numbers.  Check these before long options, since `--43' is
 337                 ;; not a long option.
 338                 ((and (op-numeric-p op)
 339                       (or (char= (char arg 0) #\-)
 340                           (op-negated-numeric-p op))
 341                       (or (and (digit-char-p (char arg 1))
 342                                (every #'digit-char-p (subseq arg 2)))
 343                           (and (or (char= (char arg 1) #\-)
 344                                    (char= (char arg 1) #\+))
 345                                (>= (length arg) 3)
 346                                (digit-char-p (char arg 2))
 347                                (every #'digit-char-p (subseq arg 3)))))
 348                  (eat-arg)
 349                  (let ((negp (char= (char arg 0) #\+))
 350                        (num (parse-integer arg :start 1)))
 351                    (when (and negp (eq (op-negated-numeric-p op) :-))
 352                      (setf num (- num))
 353                      (setf negp nil))
 354                    (let ((how (if negp
 355                                   (op-negated-numeric-p op)
 356                                   (op-numeric-p op))))
 357                      (if (functionp how)
 358                          (funcall how num)
 359                          (ret (if negp :negated-numeric :numeric) num)))))
 360                 ;;
 361                 ;; Long option.  Find the matching option-spec and process
 362                 ;; it.
 363                 ((and (char= (char arg 0) #\-)
 364                       (char= (char arg 1) #\-))
 365                  (eat-arg)
 366                  (process-long-option arg 2 nil))
 367                 ;;
 368                 ;; Short options.  All that's left.
 369                 (t
 370                  (eat-arg)
 371                  (let ((negp (char= (char arg 0) #\+))
 372                        (ch (char arg 1)))
 373                    (cond ((and (op-long-only-p op)
 374                                (not (member ch (op-options op)
 375                                             :key #'opt-short-name)))
 376                           (process-long-option arg 1 negp))
 377                          (t
 378                           (setf (op-short-opt op) arg
 379                                 (op-short-opt-index op) 1
 380                                 (op-short-opt-neg-p op) negp)))))))))))))
 381
 382 (defmacro option-parse-try (&body body)
 383   "Report errors encountered while parsing options, and continue struggling
 384 along.  Also establishes a restart `stop-parsing'.  Returns t if parsing
 385 completed successfully, or nil if errors occurred."
 386   (with-gensyms (retcode)
 387     `(let ((,retcode t))
 388        (restart-case
 389            (handler-bind
 390                ((option-parse-error
 391                  (lambda (cond)
 392                    (setf ,retcode nil)
 393                    (moan "~A" cond)
 394                    (dolist (rn '(skip-option stop-parsing))
 395                      (let ((r (find-restart rn)))
 396                        (when r (invoke-restart r)))))))
 397              ,@body)
 398          (stop-parsing ()
 399            :report "Give up parsing options."
 400            (setf ,retcode nil)))
 401        ,retcode)))
 402
 403 (defmacro with-unix-error-reporting ((&key) &body body)
 404   "Evaluate BODY with errors reported in the standard Unix fashion."
 405   (with-gensyms (cond)
 406     `(handler-case
 407          (progn ,@body)
 408        (simple-condition (,cond)
 409          (die (simple-condition-format-control ,cond)
 410               (simple-condition-format-arguments ,cond)))
 411        (error (,cond)
 412          (die "~A" ,cond)))))
 413
 414 ;;; Standard option handlers.
 415
 416 (defmacro defopthandler (name (var &optional (arg (gensym)))
 417                          (&rest args)
 418                          &body body)
 419   "Define an option handler function NAME.  Option handlers update a
 420 generalized variable, which may be referred to as VAR in the BODY, based on
 421 some parameters (the ARGS) and the value of an option-argument named ARG."
 422   (let ((func (intern (format nil "OPTHANDLER/~:@(~A~)" name))))
 423     `(progn
 424        (setf (get ',name 'opthandler) ',func)
 425        (defun ,func (,var ,arg ,@args)
 426          (with-locatives ,var
 427            (declare (ignorable ,arg))
 428            ,@body))
 429        ',name)))
 430
 431 (defun parse-c-integer (string &key radix (start 0) end)
 432   "Parse STRING, or at least the parts of it between START and END, according
 433 to the standard C rules.  Well, almost: the 0 and 0x prefixes are accepted,
 434 but so too are 0o (Haskell) and 0b (original); also RADIX_DIGITS is accepted,
 435 for any radix between 2 and 36.  Prefixes are only accepted if RADIX is nil.
 436 Returns two values: the integer parsed (or nil if there wasn't enough for a
 437 sensible parse), and the index following the characters of the integer."
 438   (unless end (setf end (length string)))
 439   (labels ((simple (a i r goodp sgn)
 440              (loop
 441                 (when (>= i end)
 442                   (return (values (and goodp (* a sgn)) i)))
 443                 (let ((d (digit-char-p (char string i) r)))
 444                   (unless d
 445                     (return (values (and goodp (* a sgn)) i)))
 446                   (setf a (+ (* a r) d))
 447                   (setf goodp t)
 448                   (incf i))))
 449            (get-radix (i r sgn)
 450              (cond (r (simple 0 i r nil sgn))
 451                    ((>= i end) (values nil i))
 452                    ((and (char= (char string i) #\0)
 453                          (>= (- end i) 2))
 454                     (case (char string (1+ i))
 455                       (#\x (simple 0 (+ i 2) 16 nil sgn))
 456                       (#\o (simple 0 (+ i 2) 8 nil sgn))
 457                       (#\b (simple 0 (+ i 2) 2 nil sgn))
 458                       (t (simple 0 (1+ i) 8 t sgn))))
 459                    (t
 460                     (multiple-value-bind
 461                           (r i)
 462                         (simple 0 i 10 nil +1)
 463                       (cond ((not r) (values nil i))
 464                             ((and (< i end)
 465                                   (char= (char string i) #\_)
 466                                   (<= 2 r 36))
 467                              (simple 0 (1+ i) r nil sgn))
 468                             (t
 469                              (values (* r sgn) i))))))))
 470     (cond ((>= start end) (values nil start))
 471           ((char= (char string start) #\-)
 472            (get-radix (1+ start) radix -1))
 473           ((char= (char string start) #\+)
 474            (get-radix (1+ start) radix +1))
 475           (t
 476            (get-radix start radix +1)))))
 477
 478 (defun invoke-option-handler (handler loc arg args)
 479   "Call the HANDLER function, giving it LOC to update, the option-argument
 480 ARG, and the remaining ARGS."
 481   (apply (if (functionp handler) handler
 482              (fdefinition (get handler 'opthandler)))
 483          loc
 484          arg
 485          args))
 486
 487 (defopthandler set (var) (&optional (value t))
 488   "Sets VAR to VALUE; defaults to t."
 489   (setf var value))
 490 (defopthandler clear (var) (&optional (value nil))
 491   "Sets VAR to VALUE; defaults to nil."
 492   (setf var value))
 493 (defopthandler inc (var) (&optional max (step 1))
 494   "Increments VAR by STEP (defaults to 1), but not greater than MAX (default
 495 nil for no maximum).  No errors are signalled."
 496   (incf var step)
 497   (when (>= var max)
 498     (setf var max)))
 499 (defopthandler dec (var) (&optional min (step 1))
 500   "Decrements VAR by STEP (defaults to 1), but not less than MIN (default nil
 501 for no maximum).  No errors are signalled."
 502   (decf var step)
 503   (when (<= var min)
 504     (setf var min)))
 505 (defopthandler read (var arg) ()
 506   "Stores in VAR the Lisp object found by reading the ARG.  Evaluation is
 507 forbidden while reading ARG.  If there is an error during reading, an error
 508 of type option-parse-error is signalled."
 509   (handler-case
 510       (let ((*read-eval* nil))
 511         (multiple-value-bind (x end) (read-from-string arg t)
 512           (unless (>= end (length arg))
 513             (option-parse-error "Junk at end of argument `~A'" arg))
 514           (setf var x)))
 515     (error (cond)
 516       (option-parse-error (format nil "~A" cond)))))
 517 (defopthandler int (var arg) (&key radix min max)
 518   "Stores in VAR the integer read from the ARG.  Integers are parsed
 519 according to C rules, which is normal in Unix; the RADIX may be nil to allow
 520 radix prefixes, or an integer between 2 and 36.  An option-parse-error is
 521 signalled if the ARG is not a valid integer, or if it is not between MIN and
 522 MAX (either of which may be nil if no lower resp. upper bound is wanted)."
 523   (multiple-value-bind (v end) (parse-c-integer arg :radix radix)
 524     (unless (and v (>= end (length arg)))
 525       (option-parse-error "Bad integer `~A'" arg))
 526     (when (or (and min (< v min))
 527               (and max (> v max)))
 528       (option-parse-error
 529        "Integer ~A out of range (must have ~@[~D <= ~]x~@[ <= ~D~])"
 530        arg min max))
 531     (setf var v)))
 532 (defopthandler string (var arg) ()
 533   "Stores ARG in VAR, just as it is."
 534   (setf var arg))
 535 (defopthandler keyword (var arg) (&rest valid)
 536   (if (null valid)
 537       (setf var (intern (string-upcase arg) :keyword))
 538       (let ((matches nil)
 539             (guess (string-upcase arg))
 540             (len (length arg)))
 541         (dolist (k valid)
 542           (let* ((kn (symbol-name k))
 543                  (klen (length kn)))
 544             (cond ((string= kn guess)
 545                    (setf matches (list k))
 546                    (return))
 547                   ((and (< len klen)
 548                         (string= guess kn :end2 len))
 549                    (push k matches)))))
 550         (case (length matches)
 551           (0 (option-parse-error "Argument `~A' invalid: must be one of:~
 552                                    ~{~%~8T~(~A~)~}"
 553                                  arg valid))
 554           (1 (setf var (car matches)))
 555           (t (option-parse-error "Argument `~A' ambiguous: may be any of:~
 556                                    ~{~%~8T~(~A~)~}"
 557                                  arg matches))))))
 558 (defopthandler list (var arg) (&optional handler &rest handler-args)
 559   "Collect ARGs in a list at VAR.  ARGs are translated by the HANDLER first,
 560 if specified.  If not, it's as if you asked for `string'."
 561   (when handler
 562     (invoke-option-handler handler (locf arg) arg handler-args))
 563   (setf var (nconc var (list arg))))
 564
 565 (compile-time-defun parse-option-form (form)
 566   "Does the heavy lifting for parsing an option form.  See the docstring for
 567 the `option' macro for details of the syntax."
 568   (flet ((doc (form)
 569            (cond ((stringp form) form)
 570                  ((null (cdr form)) (car form))
 571                  (t `(format nil ,@form))))
 572          (docp (form)
 573            (or (stringp form)
 574                (and (consp form)
 575                     (stringp (car form))))))
 576     (if (and (docp (car form))
 577              (null (cdr form)))
 578         `(%make-option :documentation ,(doc (car form)))
 579         (let (long-name short-name
 580                         arg-name arg-optional-p
 581                         tag negated-tag
 582                         doc)
 583           (dolist (f form)
 584             (cond ((and (or (not tag) (not negated-tag))
 585                         (or (keywordp f)
 586                             (and (consp f)
 587                                  (member (car f) '(lambda function)))))
 588                    (if tag
 589                        (setf negated-tag f)
 590                        (setf tag f)))
 591                   ((and (not long-name)
 592                         (or (rationalp f)
 593                             (symbolp f)
 594                             (stringp f)))
 595                    (setf long-name (if (stringp f) f
 596                                        (format nil "~(~A~)" f))))
 597                   ((and (not short-name)
 598                         (characterp f))
 599                    (setf short-name f))
 600                   ((and (not doc)
 601                         (docp f))
 602                    (setf doc (doc f)))
 603                   ((and (consp f) (symbolp (car f)))
 604                    (case (car f)
 605                      (:arg (setf arg-name (cadr f)))
 606                      (:opt-arg (setf arg-name (cadr f))
 607                                (setf arg-optional-p t))
 608                      (:doc (setf doc (doc (cdr f))))
 609                      (t (let ((handler (get (car f) 'opthandler)))
 610                           (unless handler
 611                             (error "No handler `~S' defined." (car f)))
 612                           (let* ((var (cadr f))
 613                                  (arg (gensym))
 614                                  (thunk `#'(lambda (,arg)
 615                                              (,handler (locf ,var)
 616                                                         ,arg
 617                                                         ,@(cddr f)))))
 618                             (if tag
 619                                 (setf negated-tag thunk)
 620                                 (setf tag thunk)))))))
 621                   (t
 622                    (error "Unexpected thing ~S in option form." f))))
 623           `(make-option ,long-name ,short-name ,arg-name
 624                         ,@(and arg-optional-p `(:arg-optional-p t))
 625                         ,@(and tag `(:tag ,tag))
 626                         ,@(and negated-tag `(:negated-tag ,negated-tag))
 627                         ,@(and doc `(:documentation ,doc)))))))
 628
 629 (defmacro options (&rest optlist)
 630   "More convenient way of initializing options.  The OPTLIST is a list of
 631 OPTFORMS.  Each OPTFORM is either a banner string, or a list of
 632 items.  Acceptable items are interpreted as follows:
 633
 634   KEYWORD or FUNCTION
 635     If no TAG is set yet, then as a TAG; otherwise as the NEGATED-TAG.
 636
 637   STRING (or SYMBOL or RATIONAL)
 638     If no LONG-NAME seen yet, then the LONG-NAME.  For symbols and rationals,
 639     the item is converted to a string and squashed to lower-case.
 640
 641   CHARACTER
 642      The SHORT-NAME.
 643
 644   STRING or (STRING STUFF...)
 645     If no DOCUMENTATION set yet, then the DOCUMENTATION string.  A string is
 646     used as-is; a list is considered to be a `format' string and its
 647     arguments.  This is evaluated at standard evaluation time: the option
 648     structure returned contains a simple documentation string.
 649
 650   (:ARG NAME)
 651     Set the ARG-NAME.
 652
 653   (:OPT-ARG NAME)
 654     Set the ARG-NAME, and also set ARG-OPTIONAL-P.
 655
 656   (HANDLER VAR ARGS...)
 657     If no TAG is set yet, attach the HANDLER to this option, giving it ARGS.
 658     Otherwise, set the NEGATED-TAG."
 659   `(list ,@(mapcar (lambda (form)
 660                      (if (stringp form)
 661                          `(%make-option :documentation ,form)
 662                          (parse-option-form form)))
 663                    optlist)))
 664
 665 ;;; Support stuff for help and usage messages
 666
 667 (defun print-text (string
 668                    &optional
 669                    (stream *standard-output*)
 670                    &key
 671                    (start 0)
 672                    (end nil))
 673   "Prints STRING to a pretty-printed STREAM, breaking it at whitespace and
 674 newlines in the obvious way.  Stuff between square brackets is not broken:
 675 this makes usage messages work better."
 676   (let ((i start)
 677         (nest 0)
 678         (splitp nil))
 679     (flet ((emit ()
 680              (write-string string stream :start start :end i)
 681              (setf start i)))
 682       (unless end
 683         (setf end (length string)))
 684       (loop
 685          (unless (< i end)
 686            (emit)
 687            (return))
 688          (let ((ch (char string i)))
 689            (cond ((char= ch #\newline)
 690                   (emit)
 691                   (incf start)
 692                   (pprint-newline :mandatory stream))
 693                  ((whitespace-char-p ch)
 694                   (when (zerop nest)
 695                     (setf splitp t)))
 696                  (t
 697                   (when splitp
 698                     (emit)
 699                     (pprint-newline :fill stream))
 700                   (setf splitp nil)
 701                   (case ch
 702                     (#\[ (incf nest))
 703                     (#\] (when (plusp nest) (decf nest))))))
 704            (incf i))))))
 705
 706 (defun simple-usage (opts &optional mandatory-args)
 707   "Build a simple usage list from a list of options, and (optionally)
 708 mandatory argument names."
 709   (let (short-simple long-simple short-arg long-arg)
 710     (dolist (o opts)
 711       (cond ((not (and (opt-documentation o)
 712                        (opt-long-name o))))
 713             ((and (opt-short-name o) (opt-arg-name o))
 714              (push o short-arg))
 715             ((opt-short-name o)
 716              (push o short-simple))
 717             ((opt-arg-name o)
 718              (push o long-arg))
 719             (t
 720              (push o long-simple))))
 721     (list
 722      (nconc (and short-simple
 723                  (list (format nil "[-~{~C~}]"
 724                                (sort (mapcar #'opt-short-name short-simple)
 725                                      #'char<))))
 726             (and long-simple
 727                  (mapcar (lambda (o)
 728                            (format nil "[--~A]" (opt-long-name o)))
 729                          (sort long-simple #'string< :key #'opt-long-name)))
 730             (and short-arg
 731                  (mapcar (lambda (o)
 732                            (format nil "~:[[-~C ~A]~;[-~C[~A]]~]"
 733                                    (opt-arg-optional-p o)
 734                                    (opt-short-name o)
 735                                    (opt-arg-name o)))
 736                          (sort short-arg #'char-lessp
 737                                :key #'opt-short-name)))
 738             (and long-arg
 739                  (mapcar (lambda (o)
 740                            (format nil "~:[[--~A ~A]~;[--~A[=~A]]~]"
 741                                    (opt-arg-optional-p o)
 742                                    (opt-long-name o)
 743                                    (opt-arg-name o)))
 744                          (sort long-arg #'string-lessp
 745                                :key #'opt-long-name)))
 746             (listify mandatory-args)))))
 747
 748 (defun show-usage (prog usage &optional (stream *standard-output*))
 749   "Basic usage-showing function.  PROG is the program name, probable from
 750 *command-line-strings*.  USAGE is a list of possible usages of the program,
 751 each of which is a list of items to be supplied by the user.  In simple
 752 cases, a single string is sufficient."
 753   (pprint-logical-block (stream nil :prefix "Usage: ")
 754     (dolist (u (listify usage))
 755       (pprint-logical-block (stream nil :prefix (format nil "~A " prog))
 756         (format stream "~{~A ~:_~}" (listify u)))
 757       (pprint-newline :mandatory stream))))
 758
 759 (defun show-help (prog ver usage opts &optional (stream *standard-output*))
 760   "Basic help-showing function.  PROG is the program name, probably from
 761 *command-line-strings*.  VER is the program's version number.  USAGE is a
 762 list of the possible usages of the program, each of which may be a list of
 763 items to be supplied.  OPTS is the list of supported options, as provided to
 764 the options parser.  STREAM is the stream to write on."
 765   (format stream "~A, version ~A~2%" prog ver)
 766   (show-usage prog usage stream)
 767   (terpri stream)
 768   (let (newlinep)
 769     (dolist (o opts)
 770       (let ((doc (opt-documentation o)))
 771         (cond ((not o))
 772               ((not (opt-long-name o))
 773                (when newlinep
 774                  (terpri stream)
 775                  (setf newlinep nil))
 776                (pprint-logical-block (stream nil)
 777                  (print-text doc stream))
 778                (terpri stream))
 779               (t
 780                (setf newlinep t)
 781                (pprint-logical-block (stream nil :prefix "  ")
 782                  (pprint-indent :block 30 stream)
 783                  (format stream "~:[   ~;-~:*~C,~] --~A"
 784                          (opt-short-name o)
 785                          (opt-long-name o))
 786                  (when (opt-arg-name o)
 787                    (format stream "~:[=~A~;[=~A]~]"
 788                            (opt-arg-optional-p o)
 789                            (opt-arg-name o)))
 790                  (write-string "  " stream)
 791                  (pprint-tab :line 30 1 stream)
 792                  (print-text doc stream))
 793                (terpri stream)))))))
 794
 795 (defun sanity-check-option-list (opts)
 796   "Check the option list OPTS for basic sanity.  Reused short and long option
 797 names are diagnosed.  Maybe other problems will be reported later.  Returns a
 798 list of warning strings."
 799   (let ((problems nil)
 800         (longs (make-hash-table :test #'equal))
 801         (shorts (make-hash-table)))
 802     (flet ((problem (msg &rest args)
 803              (push (apply #'format nil msg args) problems)))
 804       (dolist (o opts)
 805         (push o (gethash (opt-long-name o) longs))
 806         (push o (gethash (opt-short-name o) shorts)))
 807       (maphash (lambda (k v)
 808                  (when (and k (cdr v))
 809                    (problem "Long name `--~A' reused in ~S" k v)))
 810                longs)
 811       (maphash (lambda (k v)
 812                  (when (and k (cdr v))
 813                    (problem "Short name `-~C' reused in ~S" k v)))
 814                shorts)
 815       problems)))
 816
 817 ;;;----- That's all, folks --------------------------------------------------