1;;; Copyright (C) 1998, 2001, 2006, 2009, 2011 Free Software Foundation, Inc. 2;;; 3;;;; This library is free software; you can redistribute it and/or 4;;;; modify it under the terms of the GNU Lesser General Public 5;;;; License as published by the Free Software Foundation; either 6;;;; version 3 of the License, or (at your option) any later version. 7;;;; 8;;;; This library is distributed in the hope that it will be useful, 9;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 11;;;; Lesser General Public License for more details. 12;;;; 13;;;; You should have received a copy of the GNU Lesser General Public 14;;;; License along with this library; if not, write to the Free Software 15;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 16 17;;; Author: Russ McManus (rewritten by Thien-Thi Nguyen) 18 19;;; Commentary: 20 21;;; This module implements some complex command line option parsing, in 22;;; the spirit of the GNU C library function `getopt_long'. Both long 23;;; and short options are supported. 24;;; 25;;; The theory is that people should be able to constrain the set of 26;;; options they want to process using a grammar, rather than some arbitrary 27;;; structure. The grammar makes the option descriptions easy to read. 28;;; 29;;; `getopt-long' is a procedure for parsing command-line arguments in a 30;;; manner consistent with other GNU programs. `option-ref' is a procedure 31;;; that facilitates processing of the `getopt-long' return value. 32 33;;; (getopt-long ARGS GRAMMAR) 34;;; Parse the arguments ARGS according to the argument list grammar GRAMMAR. 35;;; 36;;; ARGS should be a list of strings. Its first element should be the 37;;; name of the program; subsequent elements should be the arguments 38;;; that were passed to the program on the command line. The 39;;; `program-arguments' procedure returns a list of this form. 40;;; 41;;; GRAMMAR is a list of the form: 42;;; ((OPTION (PROPERTY VALUE) ...) ...) 43;;; 44;;; Each OPTION should be a symbol. `getopt-long' will accept a 45;;; command-line option named `--OPTION'. 46;;; Each option can have the following (PROPERTY VALUE) pairs: 47;;; 48;;; (single-char CHAR) --- Accept `-CHAR' as a single-character 49;;; equivalent to `--OPTION'. This is how to specify traditional 50;;; Unix-style flags. 51;;; (required? BOOL) --- If BOOL is true, the option is required. 52;;; getopt-long will raise an error if it is not found in ARGS. 53;;; (value BOOL) --- If BOOL is #t, the option accepts a value; if 54;;; it is #f, it does not; and if it is the symbol 55;;; `optional', the option may appear in ARGS with or 56;;; without a value. 57;;; (predicate FUNC) --- If the option accepts a value (i.e. you 58;;; specified `(value #t)' for this option), then getopt 59;;; will apply FUNC to the value, and throw an exception 60;;; if it returns #f. FUNC should be a procedure which 61;;; accepts a string and returns a boolean value; you may 62;;; need to use quasiquotes to get it into GRAMMAR. 63;;; 64;;; The (PROPERTY VALUE) pairs may occur in any order, but each 65;;; property may occur only once. By default, options do not have 66;;; single-character equivalents, are not required, and do not take 67;;; values. 68;;; 69;;; In ARGS, single-character options may be combined, in the usual 70;;; Unix fashion: ("-x" "-y") is equivalent to ("-xy"). If an option 71;;; accepts values, then it must be the last option in the 72;;; combination; the value is the next argument. So, for example, using 73;;; the following grammar: 74;;; ((apples (single-char #\a)) 75;;; (blimps (single-char #\b) (value #t)) 76;;; (catalexis (single-char #\c) (value #t))) 77;;; the following argument lists would be acceptable: 78;;; ("-a" "-b" "bang" "-c" "couth") ("bang" and "couth" are the values 79;;; for "blimps" and "catalexis") 80;;; ("-ab" "bang" "-c" "couth") (same) 81;;; ("-ac" "couth" "-b" "bang") (same) 82;;; ("-abc" "couth" "bang") (an error, since `-b' is not the 83;;; last option in its combination) 84;;; 85;;; If an option's value is optional, then `getopt-long' decides 86;;; whether it has a value by looking at what follows it in ARGS. If 87;;; the next element is does not appear to be an option itself, then 88;;; that element is the option's value. 89;;; 90;;; The value of a long option can appear as the next element in ARGS, 91;;; or it can follow the option name, separated by an `=' character. 92;;; Thus, using the same grammar as above, the following argument lists 93;;; are equivalent: 94;;; ("--apples" "Braeburn" "--blimps" "Goodyear") 95;;; ("--apples=Braeburn" "--blimps" "Goodyear") 96;;; ("--blimps" "Goodyear" "--apples=Braeburn") 97;;; 98;;; If the option "--" appears in ARGS, argument parsing stops there; 99;;; subsequent arguments are returned as ordinary arguments, even if 100;;; they resemble options. So, in the argument list: 101;;; ("--apples" "Granny Smith" "--" "--blimp" "Goodyear") 102;;; `getopt-long' will recognize the `apples' option as having the 103;;; value "Granny Smith", but it will not recognize the `blimp' 104;;; option; it will return the strings "--blimp" and "Goodyear" as 105;;; ordinary argument strings. 106;;; 107;;; The `getopt-long' function returns the parsed argument list as an 108;;; assocation list, mapping option names --- the symbols from GRAMMAR 109;;; --- onto their values, or #t if the option does not accept a value. 110;;; Unused options do not appear in the alist. 111;;; 112;;; All arguments that are not the value of any option are returned 113;;; as a list, associated with the empty list. 114;;; 115;;; `getopt-long' throws an exception if: 116;;; - it finds an unrecognized property in GRAMMAR 117;;; - the value of the `single-char' property is not a character 118;;; - it finds an unrecognized option in ARGS 119;;; - a required option is omitted 120;;; - an option that requires an argument doesn't get one 121;;; - an option that doesn't accept an argument does get one (this can 122;;; only happen using the long option `--opt=value' syntax) 123;;; - an option predicate fails 124;;; 125;;; So, for example: 126;;; 127;;; (define grammar 128;;; `((lockfile-dir (required? #t) 129;;; (value #t) 130;;; (single-char #\k) 131;;; (predicate ,file-is-directory?)) 132;;; (verbose (required? #f) 133;;; (single-char #\v) 134;;; (value #f)) 135;;; (x-includes (single-char #\x)) 136;;; (rnet-server (single-char #\y) 137;;; (predicate ,string?)))) 138;;; 139;;; (getopt-long '("my-prog" "-vk" "/tmp" "foo1" "--x-includes=/usr/include" 140;;; "--rnet-server=lamprod" "--" "-fred" "foo2" "foo3") 141;;; grammar) 142;;; => ((() "foo1" "-fred" "foo2" "foo3") 143;;; (rnet-server . "lamprod") 144;;; (x-includes . "/usr/include") 145;;; (lockfile-dir . "/tmp") 146;;; (verbose . #t)) 147 148;;; (option-ref OPTIONS KEY DEFAULT) 149;;; Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not 150;;; found. The value is either a string or `#t'. 151;;; 152;;; For example, using the `getopt-long' return value from above: 153;;; 154;;; (option-ref (getopt-long ...) 'x-includes 42) => "/usr/include" 155;;; (option-ref (getopt-long ...) 'not-a-key! 31) => 31 156 157;;; Code: 158 159(define-module (ice-9 getopt-long) 160 #:use-module ((ice-9 common-list) #:select (remove-if-not)) 161 #:use-module (srfi srfi-9) 162 #:use-module (ice-9 match) 163 #:use-module (ice-9 regex) 164 #:use-module (ice-9 optargs) 165 #:export (getopt-long option-ref)) 166 167(define %program-name (make-fluid "guile")) 168(define (program-name) 169 (fluid-ref %program-name)) 170 171(define (fatal-error fmt . args) 172 (format (current-error-port) "~a: " (program-name)) 173 (apply format (current-error-port) fmt args) 174 (newline (current-error-port)) 175 (exit 1)) 176 177(define-record-type option-spec 178 (%make-option-spec name required? option-spec->single-char predicate value-policy) 179 option-spec? 180 (name 181 option-spec->name set-option-spec-name!) 182 (required? 183 option-spec->required? set-option-spec-required?!) 184 (option-spec->single-char 185 option-spec->single-char set-option-spec-single-char!) 186 (predicate 187 option-spec->predicate set-option-spec-predicate!) 188 (value-policy 189 option-spec->value-policy set-option-spec-value-policy!)) 190 191(define (make-option-spec name) 192 (%make-option-spec name #f #f #f #f)) 193 194(define (parse-option-spec desc) 195 (let ((spec (make-option-spec (symbol->string (car desc))))) 196 (for-each (match-lambda 197 (('required? val) 198 (set-option-spec-required?! spec val)) 199 (('value val) 200 (set-option-spec-value-policy! spec val)) 201 (('single-char val) 202 (or (char? val) 203 (error "`single-char' value must be a char!")) 204 (set-option-spec-single-char! spec val)) 205 (('predicate pred) 206 (set-option-spec-predicate! 207 spec (lambda (name val) 208 (or (not val) 209 (pred val) 210 (fatal-error "option predicate failed: --~a" 211 name))))) 212 ((prop val) 213 (error "invalid getopt-long option property:" prop))) 214 (cdr desc)) 215 spec)) 216 217(define (split-arg-list argument-list) 218 ;; Scan ARGUMENT-LIST for "--" and return (BEFORE-LS . AFTER-LS). 219 ;; Discard the "--". If no "--" is found, AFTER-LS is empty. 220 (let loop ((yes '()) (no argument-list)) 221 (cond ((null? no) (cons (reverse yes) no)) 222 ((string=? "--" (car no)) (cons (reverse yes) (cdr no))) 223 (else (loop (cons (car no) yes) (cdr no)))))) 224 225(define short-opt-rx (make-regexp "^-([a-zA-Z]+)(.*)")) 226(define long-opt-no-value-rx (make-regexp "^--([^=]+)$")) 227(define long-opt-with-value-rx (make-regexp "^--([^=]+)=(.*)")) 228 229(define (looks-like-an-option string) 230 (or (regexp-exec short-opt-rx string) 231 (regexp-exec long-opt-with-value-rx string) 232 (regexp-exec long-opt-no-value-rx string))) 233 234(define (process-options specs argument-ls stop-at-first-non-option) 235 ;; Use SPECS to scan ARGUMENT-LS; return (FOUND . ETC). 236 ;; FOUND is an unordered list of option specs for found options, while ETC 237 ;; is an order-maintained list of elements in ARGUMENT-LS that are neither 238 ;; options nor their values. 239 (let ((idx (map (lambda (spec) 240 (cons (option-spec->name spec) spec)) 241 specs)) 242 (sc-idx (map (lambda (spec) 243 (cons (make-string 1 (option-spec->single-char spec)) 244 spec)) 245 (remove-if-not option-spec->single-char specs)))) 246 (let loop ((unclumped 0) (argument-ls argument-ls) (found '()) (etc '())) 247 (define (eat! spec ls) 248 (cond 249 ((eq? 'optional (option-spec->value-policy spec)) 250 (if (or (null? ls) 251 (looks-like-an-option (car ls))) 252 (loop (- unclumped 1) ls (acons spec #t found) etc) 253 (loop (- unclumped 2) (cdr ls) (acons spec (car ls) found) etc))) 254 ((eq? #t (option-spec->value-policy spec)) 255 (if (or (null? ls) 256 (looks-like-an-option (car ls))) 257 (fatal-error "option must be specified with argument: --~a" 258 (option-spec->name spec)) 259 (loop (- unclumped 2) (cdr ls) (acons spec (car ls) found) etc))) 260 (else 261 (loop (- unclumped 1) ls (acons spec #t found) etc)))) 262 263 (match argument-ls 264 (() 265 (cons found (reverse etc))) 266 ((opt . rest) 267 (cond 268 ((regexp-exec short-opt-rx opt) 269 => (lambda (match) 270 (if (> unclumped 0) 271 ;; Next option is known not to be clumped. 272 (let* ((c (match:substring match 1)) 273 (spec (or (assoc-ref sc-idx c) 274 (fatal-error "no such option: -~a" c)))) 275 (eat! spec rest)) 276 ;; Expand a clumped group of short options. 277 (let* ((extra (match:substring match 2)) 278 (unclumped-opts 279 (append (map (lambda (c) 280 (string-append "-" (make-string 1 c))) 281 (string->list 282 (match:substring match 1))) 283 (if (string=? "" extra) '() (list extra))))) 284 (loop (length unclumped-opts) 285 (append unclumped-opts rest) 286 found 287 etc))))) 288 ((regexp-exec long-opt-no-value-rx opt) 289 => (lambda (match) 290 (let* ((opt (match:substring match 1)) 291 (spec (or (assoc-ref idx opt) 292 (fatal-error "no such option: --~a" opt)))) 293 (eat! spec rest)))) 294 ((regexp-exec long-opt-with-value-rx opt) 295 => (lambda (match) 296 (let* ((opt (match:substring match 1)) 297 (spec (or (assoc-ref idx opt) 298 (fatal-error "no such option: --~a" opt)))) 299 (if (option-spec->value-policy spec) 300 (eat! spec (cons (match:substring match 2) rest)) 301 (fatal-error "option does not support argument: --~a" 302 opt))))) 303 ((and stop-at-first-non-option 304 (<= unclumped 0)) 305 (cons found (append (reverse etc) argument-ls))) 306 (else 307 (loop (- unclumped 1) rest found (cons opt etc))))))))) 308 309(define* (getopt-long program-arguments option-desc-list 310 #:key stop-at-first-non-option) 311 "Process options, handling both long and short options, similar to 312the glibc function 'getopt_long'. PROGRAM-ARGUMENTS should be a value 313similar to what (program-arguments) returns. OPTION-DESC-LIST is a 314list of option descriptions. Each option description must satisfy the 315following grammar: 316 317 <option-spec> :: (<name> . <attribute-ls>) 318 <attribute-ls> :: (<attribute> . <attribute-ls>) 319 | () 320 <attribute> :: <required-attribute> 321 | <arg-required-attribute> 322 | <single-char-attribute> 323 | <predicate-attribute> 324 | <value-attribute> 325 <required-attribute> :: (required? <boolean>) 326 <single-char-attribute> :: (single-char <char>) 327 <value-attribute> :: (value #t) 328 (value #f) 329 (value optional) 330 <predicate-attribute> :: (predicate <1-ary-function>) 331 332 The procedure returns an alist of option names and values. Each 333option name is a symbol. The option value will be '#t' if no value 334was specified. There is a special item in the returned alist with a 335key of the empty list, (): the list of arguments that are not options 336or option values. 337 By default, options are not required, and option values are not 338required. By default, single character equivalents are not supported; 339if you want to allow the user to use single character options, you need 340to add a `single-char' clause to the option description." 341 (with-fluids ((%program-name (car program-arguments))) 342 (let* ((specifications (map parse-option-spec option-desc-list)) 343 (pair (split-arg-list (cdr program-arguments))) 344 (split-ls (car pair)) 345 (non-split-ls (cdr pair)) 346 (found/etc (process-options specifications split-ls 347 stop-at-first-non-option)) 348 (found (car found/etc)) 349 (rest-ls (append (cdr found/etc) non-split-ls))) 350 (for-each (lambda (spec) 351 (let ((name (option-spec->name spec)) 352 (val (assq-ref found spec))) 353 (and (option-spec->required? spec) 354 (or val 355 (fatal-error "option must be specified: --~a" 356 name))) 357 (let ((pred (option-spec->predicate spec))) 358 (and pred (pred name val))))) 359 specifications) 360 (for-each (lambda (spec+val) 361 (set-car! spec+val 362 (string->symbol (option-spec->name (car spec+val))))) 363 found) 364 (cons (cons '() rest-ls) found)))) 365 366(define (option-ref options key default) 367 "Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not found. 368The value is either a string or `#t'." 369 (or (assq-ref options key) default)) 370 371;;; getopt-long.scm ends here 372