#:use-module (ice-9 regex)
#:export (getopt-long option-ref))
+(define %program-name (make-fluid))
+(define (program-name)
+ (or (fluid-ref %program-name) "guile"))
+
+(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)
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))
val cur)))
(else val)))
(loop n-ls n-found n-etc))
- (define (ERR:no-arg)
- (error "option must be specified with argument:"
- (option-spec->name spec)))
(cond
((eq? 'optional (option-spec->value-policy spec))
(if (or (null? ls)
((eq? #t (option-spec->value-policy spec))
(if (or (null? ls)
(looks-like-an-option (car ls)))
- (ERR:no-arg)
+ (fatal-error "option must be specified with argument: --~a"
+ (option-spec->name spec))
(val!loop (car ls) (cdr ls) (cons spec found) etc)))
(else
(val!loop #t ls (cons spec found) etc))))
=> (lambda (match)
(let* ((c (match:substring match 1))
(spec (or (assoc-ref sc-idx c)
- (error "no such option:" c))))
+ (fatal-error "no such option: -~a" c))))
(eat! spec rest))))
((regexp-exec long-opt-no-value-rx opt)
=> (lambda (match)
(let* ((opt (match:substring match 1))
(spec (or (assoc-ref idx opt)
- (error "no such option:" 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)
- (error "no such option:" opt))))
+ (fatal-error "no such option: --~a" opt))))
(if (option-spec->value-policy spec)
(eat! spec (cons (match:substring match 2) rest))
- (error "option does not support argument:"
- opt)))))
+ (fatal-error "option does not support argument: --~a"
+ opt)))))
(else
(loop rest found (cons opt etc)))))))))
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 (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)
+ (fatal-error "option must be specified: --~a"
+ name)))
+ (and (memq spec found)
+ (eq? #t (option-spec->value-policy spec))
+ (or val
+ (fatal-error
+ "option must be specified with argument: --~a"
+ 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))))))
(define (option-ref options key default)
"Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not found.
;;;; getopt-long.test --- long options processing -*- scheme -*-
;;;; Thien-Thi Nguyen <ttn@gnu.org> --- August 2001
;;;;
-;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2006, 2011 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
(ice-9 getopt-long)
(ice-9 regex))
+(define-syntax pass-if-fatal-exception
+ (syntax-rules ()
+ ((_ name exn exp)
+ (let ((port (open-output-string)))
+ (with-error-to-port port
+ (lambda ()
+ (run-test
+ name #t
+ (lambda ()
+ (catch (car exn)
+ (lambda () exp #f)
+ (lambda (k . args)
+ (let ((output (get-output-string port)))
+ (close-port port)
+ (if (string-match (cdr exn) output)
+ #t
+ (error "Unexpected output" output)))))))))))))
+
(defmacro deferr (name-frag re)
(let ((name (symbol-append 'exception: name-frag)))
- `(define ,name (cons 'misc-error ,re))))
+ `(define ,name (cons 'quit ,re))))
-(deferr no-such-option "^no such option")
-(deferr option-predicate-failed "^option predicate failed")
-(deferr option-does-not-support-arg "^option does not support argument")
-(deferr option-must-be-specified "^option must be specified")
-(deferr option-must-have-arg "^option must be specified with argument")
+(deferr no-such-option "no such option")
+(deferr option-predicate-failed "option predicate failed")
+(deferr option-does-not-support-arg "option does not support argument")
+(deferr option-must-be-specified "option must be specified")
+(deferr option-must-have-arg "option must be specified with argument")
(with-test-prefix "exported procs"
(pass-if "`option-ref' defined" (defined? 'option-ref))
(equal? (test1 "foo" "bar" "--test=123")
'((() "bar") (test . "123"))))
- (pass-if-exception "invalid arg"
+ (pass-if-fatal-exception "invalid arg"
exception:option-predicate-failed
(test1 "foo" "bar" "--test=foo"))
- (pass-if-exception "option has no arg"
+ (pass-if-fatal-exception "option has no arg"
exception:option-must-have-arg
(test1 "foo" "bar" "--test"))
(equal? (test5 '() '())
'((()))))
- (pass-if-exception "not mentioned, given"
+ (pass-if-fatal-exception "not mentioned, given"
exception:no-such-option
(test5 '("--req") '((something))))
(equal? (test5 '("--req" "7") '((req (required? #f) (value #t))))
'((()) (req . "7"))))
- (pass-if-exception "specified required, not given"
+ (pass-if-fatal-exception "specified required, not given"
exception:option-must-be-specified
(test5 '() '((req (required? #t)))))
(define (test6 args specs)
(getopt-long (cons "foo" args) specs))
- (pass-if-exception "using \"=\" syntax"
+ (pass-if-fatal-exception "using \"=\" syntax"
exception:option-does-not-support-arg
(test6 '("--maybe=yes") '((maybe))))
(equal? (test7 '("--hmm=101"))
'((()) (hmm . "101"))))
- (pass-if-exception "short opt, arg not given"
+ (pass-if-fatal-exception "short opt, arg not given"
exception:option-must-have-arg
(test7 '("-H")))
- (pass-if-exception "long non-\"=\" opt, arg not given (next arg an option)"
+ (pass-if-fatal-exception "long non-\"=\" opt, arg not given (next arg an option)"
exception:option-must-have-arg
(test7 '("--hmm" "--ignore")))
- (pass-if-exception "long \"=\" opt, arg not given"
+ (pass-if-fatal-exception "long \"=\" opt, arg not given"
exception:option-must-have-arg
(test7 '("--hmm")))
(pass-if "normal 2" (test8 "-ab" "bang" "-c" "couth"))
(pass-if "normal 3" (test8 "-ac" "couth" "-b" "bang"))
- (pass-if-exception "bad ordering causes missing option"
+ (pass-if-fatal-exception "bad ordering causes missing option"
exception:option-must-have-arg
(test8 "-abc" "couth" "bang"))
HCoop / bpt / guile.git / commitdiff