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.

2 files changed, 94 insertions, 64 deletions

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 <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
@@ -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"))