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