diff --git a/module/ice-9/getopt-long.scm b/module/ice-9/getopt-long.scm index c16efdd63..1b170b494 100644 --- a/module/ice-9/getopt-long.scm +++ b/module/ice-9/getopt-long.scm @@ -163,6 +163,16 @@ #: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) @@ -199,7 +209,8 @@ 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)) @@ -267,9 +278,6 @@ 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) @@ -279,7 +287,8 @@ ((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)))) @@ -293,23 +302,23 @@ => (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))))))))) @@ -344,44 +353,47 @@ or option values. 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. diff --git a/test-suite/tests/getopt-long.test b/test-suite/tests/getopt-long.test index 2c6f41515..d7f518482 100644 --- a/test-suite/tests/getopt-long.test +++ b/test-suite/tests/getopt-long.test @@ -1,7 +1,7 @@ ;;;; getopt-long.test --- long options processing -*- scheme -*- ;;;; Thien-Thi Nguyen --- 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 @@ -21,15 +21,33 @@ (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)) @@ -47,11 +65,11 @@ (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")) @@ -138,7 +156,7 @@ (equal? (test5 '() '()) '((())))) - (pass-if-exception "not mentioned, given" + (pass-if-fatal-exception "not mentioned, given" exception:no-such-option (test5 '("--req") '((something)))) @@ -158,7 +176,7 @@ (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))))) @@ -169,7 +187,7 @@ (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)))) @@ -193,15 +211,15 @@ (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"))) @@ -228,7 +246,7 @@ (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"))