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