mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-01 12:20:26 +02:00
getopt-long: arg parsing errors cause print and exit, not backtrace
* module/ice-9/getopt-long.scm (fatal-error): New helper. For errors that come from the user -- i.e., not the grammar -- we will handle our own error printing and call `exit' rather than relying on the root catch handler. This is more friendly to the user than a Scheme backtrace. (parse-option-spec, process-options, getopt-long): Call `fatal-error' as appropriate. * test-suite/tests/getopt-long.test (pass-if-fatal-exception): New helper, checks that a certain key was thrown to, and that suitable output has been printed on an error port. (deferr): Change to expect a 'quit key instead of 'misc-error. Update exceptions to not match the beginning of the string, as that will be the program name. Update tests to use pass-if-fatal-exception.
This commit is contained in:
Andy Wingo
parent
13f607c175
commit
0bc86fcedc
2 changed files with 94 additions and 64 deletions
|
|
@ -163,6 +163,16 @@
|
||||||
#:use-module (ice-9 regex)
|
#:use-module (ice-9 regex)
|
||||||
#:export (getopt-long option-ref))
|
#: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
|
(define-record-type option-spec
|
||||||
(%make-option-spec name value required? single-char predicate
|
(%make-option-spec name value required? single-char predicate
|
||||||
value-policy)
|
value-policy)
|
||||||
|
|
@ -199,7 +209,8 @@
|
||||||
spec (lambda (name val)
|
spec (lambda (name val)
|
||||||
(or (not val)
|
(or (not val)
|
||||||
(pred val)
|
(pred val)
|
||||||
(error "option predicate failed:" name)))))
|
(fatal-error "option predicate failed: --~a"
|
||||||
|
name)))))
|
||||||
((prop val)
|
((prop val)
|
||||||
(error "invalid getopt-long option property:" prop)))
|
(error "invalid getopt-long option property:" prop)))
|
||||||
(cdr desc))
|
(cdr desc))
|
||||||
|
|
@ -267,9 +278,6 @@
|
||||||
val cur)))
|
val cur)))
|
||||||
(else val)))
|
(else val)))
|
||||||
(loop n-ls n-found n-etc))
|
(loop n-ls n-found n-etc))
|
||||||
(define (ERR:no-arg)
|
|
||||||
(error "option must be specified with argument:"
|
|
||||||
(option-spec->name spec)))
|
|
||||||
(cond
|
(cond
|
||||||
((eq? 'optional (option-spec->value-policy spec))
|
((eq? 'optional (option-spec->value-policy spec))
|
||||||
(if (or (null? ls)
|
(if (or (null? ls)
|
||||||
|
|
@ -279,7 +287,8 @@
|
||||||
((eq? #t (option-spec->value-policy spec))
|
((eq? #t (option-spec->value-policy spec))
|
||||||
(if (or (null? ls)
|
(if (or (null? ls)
|
||||||
(looks-like-an-option (car 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)))
|
(val!loop (car ls) (cdr ls) (cons spec found) etc)))
|
||||||
(else
|
(else
|
||||||
(val!loop #t ls (cons spec found) etc))))
|
(val!loop #t ls (cons spec found) etc))))
|
||||||
|
|
@ -293,23 +302,23 @@
|
||||||
=> (lambda (match)
|
=> (lambda (match)
|
||||||
(let* ((c (match:substring match 1))
|
(let* ((c (match:substring match 1))
|
||||||
(spec (or (assoc-ref sc-idx c)
|
(spec (or (assoc-ref sc-idx c)
|
||||||
(error "no such option:" c))))
|
(fatal-error "no such option: -~a" c))))
|
||||||
(eat! spec rest))))
|
(eat! spec rest))))
|
||||||
((regexp-exec long-opt-no-value-rx opt)
|
((regexp-exec long-opt-no-value-rx opt)
|
||||||
=> (lambda (match)
|
=> (lambda (match)
|
||||||
(let* ((opt (match:substring match 1))
|
(let* ((opt (match:substring match 1))
|
||||||
(spec (or (assoc-ref idx opt)
|
(spec (or (assoc-ref idx opt)
|
||||||
(error "no such option:" opt))))
|
(fatal-error "no such option: --~a" opt))))
|
||||||
(eat! spec rest))))
|
(eat! spec rest))))
|
||||||
((regexp-exec long-opt-with-value-rx opt)
|
((regexp-exec long-opt-with-value-rx opt)
|
||||||
=> (lambda (match)
|
=> (lambda (match)
|
||||||
(let* ((opt (match:substring match 1))
|
(let* ((opt (match:substring match 1))
|
||||||
(spec (or (assoc-ref idx opt)
|
(spec (or (assoc-ref idx opt)
|
||||||
(error "no such option:" opt))))
|
(fatal-error "no such option: --~a" opt))))
|
||||||
(if (option-spec->value-policy spec)
|
(if (option-spec->value-policy spec)
|
||||||
(eat! spec (cons (match:substring match 2) rest))
|
(eat! spec (cons (match:substring match 2) rest))
|
||||||
(error "option does not support argument:"
|
(fatal-error "option does not support argument: --~a"
|
||||||
opt)))))
|
opt)))))
|
||||||
(else
|
(else
|
||||||
(loop rest found (cons opt etc)))))))))
|
(loop rest found (cons opt etc)))))))))
|
||||||
|
|
||||||
|
|
@ -344,44 +353,47 @@ or option values.
|
||||||
required. By default, single character equivalents are not supported;
|
required. By default, single character equivalents are not supported;
|
||||||
if you want to allow the user to use single character options, you need
|
if you want to allow the user to use single character options, you need
|
||||||
to add a `single-char' clause to the option description."
|
to add a `single-char' clause to the option description."
|
||||||
(let* ((specifications (map parse-option-spec option-desc-list))
|
(with-fluids ((%program-name (car program-arguments)))
|
||||||
(pair (split-arg-list (cdr program-arguments)))
|
(let* ((specifications (map parse-option-spec option-desc-list))
|
||||||
(split-ls (expand-clumped-singles (car pair)))
|
(pair (split-arg-list (cdr program-arguments)))
|
||||||
(non-split-ls (cdr pair))
|
(split-ls (expand-clumped-singles (car pair)))
|
||||||
(found/etc (process-options specifications split-ls))
|
(non-split-ls (cdr pair))
|
||||||
(found (car found/etc))
|
(found/etc (process-options specifications split-ls))
|
||||||
(rest-ls (append (cdr found/etc) non-split-ls)))
|
(found (car found/etc))
|
||||||
(for-each (lambda (spec)
|
(rest-ls (append (cdr found/etc) non-split-ls)))
|
||||||
(let ((name (option-spec->name spec))
|
(for-each (lambda (spec)
|
||||||
(val (option-spec->value spec)))
|
(let ((name (option-spec->name spec))
|
||||||
(and (option-spec->required? spec)
|
(val (option-spec->value spec)))
|
||||||
(or (memq spec found)
|
(and (option-spec->required? spec)
|
||||||
(error "option must be specified:" name)))
|
(or (memq spec found)
|
||||||
(and (memq spec found)
|
(fatal-error "option must be specified: --~a"
|
||||||
(eq? #t (option-spec->value-policy spec))
|
name)))
|
||||||
(or val
|
(and (memq spec found)
|
||||||
(error "option must be specified with argument:"
|
(eq? #t (option-spec->value-policy spec))
|
||||||
name)))
|
(or val
|
||||||
(let ((pred (option-spec->predicate spec)))
|
(fatal-error
|
||||||
(and pred (pred name val)))))
|
"option must be specified with argument: --~a"
|
||||||
specifications)
|
name)))
|
||||||
(cons (cons '() rest-ls)
|
(let ((pred (option-spec->predicate spec)))
|
||||||
(let ((multi-count (map (lambda (desc)
|
(and pred (pred name val)))))
|
||||||
(cons (car desc) 0))
|
specifications)
|
||||||
option-desc-list)))
|
(cons (cons '() rest-ls)
|
||||||
(map (lambda (spec)
|
(let ((multi-count (map (lambda (desc)
|
||||||
(let ((name (string->symbol (option-spec->name spec))))
|
(cons (car desc) 0))
|
||||||
(cons name
|
option-desc-list)))
|
||||||
;; handle multiple occurrances
|
(map (lambda (spec)
|
||||||
(let ((maybe-ls (option-spec->value spec)))
|
(let ((name (string->symbol (option-spec->name spec))))
|
||||||
(if (list? maybe-ls)
|
(cons name
|
||||||
(let* ((look (assq name multi-count))
|
;; handle multiple occurrances
|
||||||
(idx (cdr look))
|
(let ((maybe-ls (option-spec->value spec)))
|
||||||
(val (list-ref maybe-ls idx)))
|
(if (list? maybe-ls)
|
||||||
(set-cdr! look (1+ idx)) ; ugh!
|
(let* ((look (assq name multi-count))
|
||||||
val)
|
(idx (cdr look))
|
||||||
maybe-ls)))))
|
(val (list-ref maybe-ls idx)))
|
||||||
found)))))
|
(set-cdr! look (1+ idx)) ; ugh!
|
||||||
|
val)
|
||||||
|
maybe-ls)))))
|
||||||
|
found))))))
|
||||||
|
|
||||||
(define (option-ref options key default)
|
(define (option-ref options key default)
|
||||||
"Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not found.
|
"Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not found.
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,7 @@
|
||||||
;;;; getopt-long.test --- long options processing -*- scheme -*-
|
;;;; getopt-long.test --- long options processing -*- scheme -*-
|
||||||
;;;; Thien-Thi Nguyen <ttn@gnu.org> --- August 2001
|
;;;; 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
|
;;;; This library is free software; you can redistribute it and/or
|
||||||
;;;; modify it under the terms of the GNU Lesser General Public
|
;;;; modify it under the terms of the GNU Lesser General Public
|
||||||
|
|
@ -21,15 +21,33 @@
|
||||||
(ice-9 getopt-long)
|
(ice-9 getopt-long)
|
||||||
(ice-9 regex))
|
(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)
|
(defmacro deferr (name-frag re)
|
||||||
(let ((name (symbol-append 'exception: name-frag)))
|
(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 no-such-option "no such option")
|
||||||
(deferr option-predicate-failed "^option predicate failed")
|
(deferr option-predicate-failed "option predicate failed")
|
||||||
(deferr option-does-not-support-arg "^option does not support argument")
|
(deferr option-does-not-support-arg "option does not support argument")
|
||||||
(deferr option-must-be-specified "^option must be specified")
|
(deferr option-must-be-specified "option must be specified")
|
||||||
(deferr option-must-have-arg "^option must be specified with argument")
|
(deferr option-must-have-arg "option must be specified with argument")
|
||||||
|
|
||||||
(with-test-prefix "exported procs"
|
(with-test-prefix "exported procs"
|
||||||
(pass-if "`option-ref' defined" (defined? 'option-ref))
|
(pass-if "`option-ref' defined" (defined? 'option-ref))
|
||||||
|
|
@ -47,11 +65,11 @@
|
||||||
(equal? (test1 "foo" "bar" "--test=123")
|
(equal? (test1 "foo" "bar" "--test=123")
|
||||||
'((() "bar") (test . "123"))))
|
'((() "bar") (test . "123"))))
|
||||||
|
|
||||||
(pass-if-exception "invalid arg"
|
(pass-if-fatal-exception "invalid arg"
|
||||||
exception:option-predicate-failed
|
exception:option-predicate-failed
|
||||||
(test1 "foo" "bar" "--test=foo"))
|
(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
|
exception:option-must-have-arg
|
||||||
(test1 "foo" "bar" "--test"))
|
(test1 "foo" "bar" "--test"))
|
||||||
|
|
||||||
|
|
@ -138,7 +156,7 @@
|
||||||
(equal? (test5 '() '())
|
(equal? (test5 '() '())
|
||||||
'((()))))
|
'((()))))
|
||||||
|
|
||||||
(pass-if-exception "not mentioned, given"
|
(pass-if-fatal-exception "not mentioned, given"
|
||||||
exception:no-such-option
|
exception:no-such-option
|
||||||
(test5 '("--req") '((something))))
|
(test5 '("--req") '((something))))
|
||||||
|
|
||||||
|
|
@ -158,7 +176,7 @@
|
||||||
(equal? (test5 '("--req" "7") '((req (required? #f) (value #t))))
|
(equal? (test5 '("--req" "7") '((req (required? #f) (value #t))))
|
||||||
'((()) (req . "7"))))
|
'((()) (req . "7"))))
|
||||||
|
|
||||||
(pass-if-exception "specified required, not given"
|
(pass-if-fatal-exception "specified required, not given"
|
||||||
exception:option-must-be-specified
|
exception:option-must-be-specified
|
||||||
(test5 '() '((req (required? #t)))))
|
(test5 '() '((req (required? #t)))))
|
||||||
|
|
||||||
|
|
@ -169,7 +187,7 @@
|
||||||
(define (test6 args specs)
|
(define (test6 args specs)
|
||||||
(getopt-long (cons "foo" 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
|
exception:option-does-not-support-arg
|
||||||
(test6 '("--maybe=yes") '((maybe))))
|
(test6 '("--maybe=yes") '((maybe))))
|
||||||
|
|
||||||
|
|
@ -193,15 +211,15 @@
|
||||||
(equal? (test7 '("--hmm=101"))
|
(equal? (test7 '("--hmm=101"))
|
||||||
'((()) (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
|
exception:option-must-have-arg
|
||||||
(test7 '("-H")))
|
(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
|
exception:option-must-have-arg
|
||||||
(test7 '("--hmm" "--ignore")))
|
(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
|
exception:option-must-have-arg
|
||||||
(test7 '("--hmm")))
|
(test7 '("--hmm")))
|
||||||
|
|
||||||
|
|
@ -228,7 +246,7 @@
|
||||||
(pass-if "normal 2" (test8 "-ab" "bang" "-c" "couth"))
|
(pass-if "normal 2" (test8 "-ab" "bang" "-c" "couth"))
|
||||||
(pass-if "normal 3" (test8 "-ac" "couth" "-b" "bang"))
|
(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
|
exception:option-must-have-arg
|
||||||
(test8 "-abc" "couth" "bang"))
|
(test8 "-abc" "couth" "bang"))
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue