;;; Code:
(define-module (ice-9 getopt-long)
- #:use-module ((ice-9 common-list) #:select (some remove-if-not))
+ #:use-module ((ice-9 common-list) #:select (remove-if-not))
#:use-module (srfi srfi-9)
#:use-module (ice-9 match)
+ #:use-module (ice-9 regex)
+ #:use-module (ice-9 optargs)
#:export (getopt-long option-ref))
+(define %program-name (make-fluid "guile"))
+(define (program-name)
+ (fluid-ref %program-name))
+
+(define (fatal-error fmt . args)
+ (format (current-error-port) "~a: " (program-name))
+ (apply format (current-error-port) fmt args)
+ (newline (current-error-port))
+ (exit 1))
+
(define-record-type option-spec
- (%make-option-spec name value required? single-char predicate
- value-policy)
+ (%make-option-spec name required? option-spec->single-char predicate value-policy)
option-spec?
(name
option-spec->name set-option-spec-name!)
- (value
- option-spec->value set-option-spec-value!)
(required?
option-spec->required? set-option-spec-required?!)
(option-spec->single-char
option-spec->value-policy set-option-spec-value-policy!))
(define (make-option-spec name)
- (%make-option-spec name #f #f #f #f #f))
+ (%make-option-spec name #f #f #f #f))
(define (parse-option-spec desc)
(let ((spec (make-option-spec (symbol->string (car desc)))))
spec (lambda (name val)
(or (not val)
(pred val)
- (error "option predicate failed:" name)))))
+ (fatal-error "option predicate failed: --~a"
+ name)))))
((prop val)
(error "invalid getopt-long option property:" prop)))
(cdr desc))
(define long-opt-no-value-rx (make-regexp "^--([^=]+)$"))
(define long-opt-with-value-rx (make-regexp "^--([^=]+)=(.*)"))
-(define (match-substring match which)
- ;; condensed from (ice-9 regex) `match:{substring,start,end}'
- (let ((sel (vector-ref match (1+ which))))
- (substring (vector-ref match 0) (car sel) (cdr sel))))
-
-(define (expand-clumped-singles opt-ls)
- ;; example: ("--xyz" "-abc5d") => ("--xyz" "-a" "-b" "-c" "5d")
- (let loop ((opt-ls opt-ls) (ret-ls '()))
- (cond ((null? opt-ls)
- (reverse ret-ls)) ;;; retval
- ((regexp-exec short-opt-rx (car opt-ls))
- => (lambda (match)
- (let ((singles (reverse
- (map (lambda (c)
- (string-append "-" (make-string 1 c)))
- (string->list
- (match-substring match 1)))))
- (extra (match-substring match 2)))
- (loop (cdr opt-ls)
- (append (if (string=? "" extra)
- singles
- (cons extra singles))
- ret-ls)))))
- (else (loop (cdr opt-ls)
- (cons (car opt-ls) ret-ls))))))
-
(define (looks-like-an-option string)
- (some (lambda (rx)
- (regexp-exec rx string))
- `(,short-opt-rx
- ,long-opt-with-value-rx
- ,long-opt-no-value-rx)))
+ (or (regexp-exec short-opt-rx string)
+ (regexp-exec long-opt-with-value-rx string)
+ (regexp-exec long-opt-no-value-rx string)))
-(define (process-options specs argument-ls)
+(define (process-options specs argument-ls stop-at-first-non-option)
;; Use SPECS to scan ARGUMENT-LS; return (FOUND . ETC).
;; FOUND is an unordered list of option specs for found options, while ETC
;; is an order-maintained list of elements in ARGUMENT-LS that are neither
(cons (make-string 1 (option-spec->single-char spec))
spec))
(remove-if-not option-spec->single-char specs))))
- (let loop ((argument-ls argument-ls) (found '()) (etc '()))
- (let ((eat! (lambda (spec ls)
- (let ((val!loop (lambda (val n-ls n-found n-etc)
- (set-option-spec-value!
- spec
- ;; handle multiple occurrances
- (cond ((option-spec->value spec)
- => (lambda (cur)
- ((if (list? cur) cons list)
- val cur)))
- (else val)))
- (loop n-ls n-found n-etc)))
- (ERR:no-arg (lambda ()
- (error (string-append
- "option must be specified"
- " with argument:")
- (option-spec->name spec)))))
- (cond
- ((eq? 'optional (option-spec->value-policy spec))
- (if (or (null? (cdr ls))
- (looks-like-an-option (cadr ls)))
- (val!loop #t
- (cdr ls)
- (cons spec found)
- etc)
- (val!loop (cadr ls)
- (cddr ls)
- (cons spec found)
- etc)))
- ((eq? #t (option-spec->value-policy spec))
- (if (or (null? (cdr ls))
- (looks-like-an-option (cadr ls)))
- (ERR:no-arg)
- (val!loop (cadr ls)
- (cddr ls)
- (cons spec found)
- etc)))
- (else
- (val!loop #t
- (cdr ls)
- (cons spec found)
- etc)))))))
- (if (null? argument-ls)
- (cons found (reverse etc)) ;;; retval
- (cond ((regexp-exec short-opt-rx (car argument-ls))
- => (lambda (match)
- (let* ((c (match-substring match 1))
- (spec (or (assoc-ref sc-idx c)
- (error "no such option:" c))))
- (eat! spec argument-ls))))
- ((regexp-exec long-opt-no-value-rx (car argument-ls))
- => (lambda (match)
- (let* ((opt (match-substring match 1))
- (spec (or (assoc-ref idx opt)
- (error "no such option:" opt))))
- (eat! spec argument-ls))))
- ((regexp-exec long-opt-with-value-rx (car argument-ls))
- => (lambda (match)
- (let* ((opt (match-substring match 1))
- (spec (or (assoc-ref idx opt)
- (error "no such option:" opt))))
- (if (option-spec->value-policy spec)
- (eat! spec (append
- (list 'ignored
- (match-substring match 2))
- (cdr argument-ls)))
- (error "option does not support argument:"
- opt)))))
- (else
- (loop (cdr argument-ls)
- found
- (cons (car argument-ls) etc)))))))))
+ (let loop ((unclumped 0) (argument-ls argument-ls) (found '()) (etc '()))
+ (define (eat! spec ls)
+ (cond
+ ((eq? 'optional (option-spec->value-policy spec))
+ (if (or (null? ls)
+ (looks-like-an-option (car ls)))
+ (loop (- unclumped 1) ls (acons spec #t found) etc)
+ (loop (- unclumped 2) (cdr ls) (acons spec (car ls) found) etc)))
+ ((eq? #t (option-spec->value-policy spec))
+ (if (or (null? ls)
+ (looks-like-an-option (car ls)))
+ (fatal-error "option must be specified with argument: --~a"
+ (option-spec->name spec))
+ (loop (- unclumped 2) (cdr ls) (acons spec (car ls) found) etc)))
+ (else
+ (loop (- unclumped 1) ls (acons spec #t found) etc))))
+
+ (match argument-ls
+ (()
+ (cons found (reverse etc)))
+ ((opt . rest)
+ (cond
+ ((regexp-exec short-opt-rx opt)
+ => (lambda (match)
+ (if (> unclumped 0)
+ ;; Next option is known not to be clumped.
+ (let* ((c (match:substring match 1))
+ (spec (or (assoc-ref sc-idx c)
+ (fatal-error "no such option: -~a" c))))
+ (eat! spec rest))
+ ;; Expand a clumped group of short options.
+ (let* ((extra (match:substring match 2))
+ (unclumped-opts
+ (append (map (lambda (c)
+ (string-append "-" (make-string 1 c)))
+ (string->list
+ (match:substring match 1)))
+ (if (string=? "" extra) '() (list extra)))))
+ (loop (length unclumped-opts)
+ (append unclumped-opts rest)
+ found
+ etc)))))
+ ((regexp-exec long-opt-no-value-rx opt)
+ => (lambda (match)
+ (let* ((opt (match:substring match 1))
+ (spec (or (assoc-ref idx opt)
+ (fatal-error "no such option: --~a" opt))))
+ (eat! spec rest))))
+ ((regexp-exec long-opt-with-value-rx opt)
+ => (lambda (match)
+ (let* ((opt (match:substring match 1))
+ (spec (or (assoc-ref idx opt)
+ (fatal-error "no such option: --~a" opt))))
+ (if (option-spec->value-policy spec)
+ (eat! spec (cons (match:substring match 2) rest))
+ (fatal-error "option does not support argument: --~a"
+ opt)))))
+ ((and stop-at-first-non-option
+ (<= unclumped 0))
+ (cons found (append (reverse etc) argument-ls)))
+ (else
+ (loop (- unclumped 1) rest found (cons opt etc)))))))))
-(define (getopt-long program-arguments option-desc-list)
+(define* (getopt-long program-arguments option-desc-list
+ #:key stop-at-first-non-option)
"Process options, handling both long and short options, similar to
the glibc function 'getopt_long'. PROGRAM-ARGUMENTS should be a value
similar to what (program-arguments) returns. OPTION-DESC-LIST is a
required. By default, single character equivalents are not supported;
if you want to allow the user to use single character options, you need
to add a `single-char' clause to the option description."
- (let* ((specifications (map parse-option-spec option-desc-list))
- (pair (split-arg-list (cdr program-arguments)))
- (split-ls (expand-clumped-singles (car pair)))
- (non-split-ls (cdr pair))
- (found/etc (process-options specifications split-ls))
- (found (car found/etc))
- (rest-ls (append (cdr found/etc) non-split-ls)))
- (for-each (lambda (spec)
- (let ((name (option-spec->name spec))
- (val (option-spec->value spec)))
- (and (option-spec->required? spec)
- (or (memq spec found)
- (error "option must be specified:" name)))
- (and (memq spec found)
- (eq? #t (option-spec->value-policy spec))
- (or val
- (error "option must be specified with argument:"
- name)))
- (let ((pred (option-spec->predicate spec)))
- (and pred (pred name val)))))
- specifications)
- (cons (cons '() rest-ls)
- (let ((multi-count (map (lambda (desc)
- (cons (car desc) 0))
- option-desc-list)))
- (map (lambda (spec)
- (let ((name (string->symbol (option-spec->name spec))))
- (cons name
- ;; handle multiple occurrances
- (let ((maybe-ls (option-spec->value spec)))
- (if (list? maybe-ls)
- (let* ((look (assq name multi-count))
- (idx (cdr look))
- (val (list-ref maybe-ls idx)))
- (set-cdr! look (1+ idx)) ; ugh!
- val)
- maybe-ls)))))
- found)))))
+ (with-fluids ((%program-name (car program-arguments)))
+ (let* ((specifications (map parse-option-spec option-desc-list))
+ (pair (split-arg-list (cdr program-arguments)))
+ (split-ls (car pair))
+ (non-split-ls (cdr pair))
+ (found/etc (process-options specifications split-ls
+ stop-at-first-non-option))
+ (found (car found/etc))
+ (rest-ls (append (cdr found/etc) non-split-ls)))
+ (for-each (lambda (spec)
+ (let ((name (option-spec->name spec))
+ (val (assq-ref found spec)))
+ (and (option-spec->required? spec)
+ (or val
+ (fatal-error "option must be specified: --~a"
+ name)))
+ (let ((pred (option-spec->predicate spec)))
+ (and pred (pred name val)))))
+ specifications)
+ (for-each (lambda (spec+val)
+ (set-car! spec+val
+ (string->symbol (option-spec->name (car spec+val)))))
+ found)
+ (cons (cons '() rest-ls) found))))
(define (option-ref options key default)
"Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not found.
HCoop / bpt / guile.git / blobdiff