[Guile-commits] GNU Guile branch, master, updated. release_1-9-14-119-g92a70bc

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=92a70bcf299632e5b19f86ab4629d4e24a09a7e1

The branch, master has been updated
       via  92a70bcf299632e5b19f86ab4629d4e24a09a7e1 (commit)
      from  bc312c45dda409fc30027cebca72f6d2ced4f60c (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 92a70bcf299632e5b19f86ab4629d4e24a09a7e1
Author: Andy Wingo <address@hidden>
Date:   Thu Jan 27 18:18:10 2011 +0100

    fix guile-tools getopt
    
    * meta/guile-tools.in (getopt): Define a local version of getopt that
      stops parsing options when it sees a non-option.

-----------------------------------------------------------------------

Summary of changes:
 meta/guile-tools.in |  117 +++++++++++++++++++++++++++++++++++++--------------
 1 files changed, 85 insertions(+), 32 deletions(-)

diff --git a/meta/guile-tools.in b/meta/guile-tools.in
index cdcb610..a0822ae 100755
--- a/meta/guile-tools.in
+++ b/meta/guile-tools.in
@@ -25,8 +25,7 @@ exec guile $GUILE_FLAGS -e '(@@ (guile-tools) main)' -s "$0" 
"$@"
 
 (define-module (guile-tools)
   #:use-module ((srfi srfi-1) #:select (fold append-map))
-  #:autoload (ice-9 format) (format)
-  #:use-module (ice-9 getopt-long))
+  #:autoload (ice-9 format) (format))
 
 ;; Hack to provide scripts with the bug-report address.
 (module-define! the-scm-module
@@ -110,36 +109,90 @@ There is NO WARRANTY, to the extent permitted by law.
   (resolve-module (list 'scripts (string->symbol s)) #:ensure #f))
 
 (define (getopt args grammar)
-  (catch 'misc-error
-    (lambda ()
-      (getopt-long args grammar))
-    (lambda (k proc fmt args . extra)
-      (format (current-error-port)
-              "guile-tools: ~?~%" fmt args)
-      (format (current-error-port)
-              "Try `guile-tools --help' for more information.~%")
-      (exit 1))))
+  (define (fail)
+    (format (current-error-port)
+            "Try `guile-tools --help' for more information.~%")
+    (exit 1))
+
+  (define (unrecognized-arg arg)
+    (format (current-error-port)
+            "guile-tools: unrecognized option: `~a'~%" arg)
+    (fail))
+
+  (define (unexpected-value sym val)
+    (format (current-error-port)
+            "guile-tools: option `--~a' does not take an argument (given ~s)~%"
+            sym val)
+    (fail))
+
+  (define (single-char-table grammar)
+    (cond
+     ((null? grammar) '())
+     ((assq 'single-char (cdar grammar))
+      => (lambda (form)
+           (acons (cadr form) (car grammar)
+                  (single-char-table (cdr grammar)))))
+     (else
+      (single-char-table (cdr grammar)))))
+  
+  (let ((single (single-char-table grammar)))
+    (let lp ((args (cdr args)) (options '()))
+      (cond
+       ((or (null? args) (equal? (car args) "-"))
+        (values (reverse options) args))
+       ((equal? (car args) "--")
+        (values (reverse options) (cdr args)))
+       ((string-prefix? "--" (car args))
+        (let* ((str (car args))
+               (eq (string-index str #\= 2))
+               (sym (string->symbol
+                     (substring str 2 (or eq (string-length str)))))
+               (val (and eq (substring str (1+ eq))))
+               (spec (assq sym grammar)))
+          (cond
+           ((not spec)
+            (unrecognized-arg (substring str 0 (or eq (string-length str)))))
+           (val
+            ;; no values for now
+            (unexpected-value sym val))
+           ((assq-ref (cdr spec) 'value)
+            (error "options with values not supported right now"))
+           (else
+            (lp (cdr args) (acons sym #f options))))))
+       ((string-prefix? "-" (car args))
+        (let lp* ((chars (cdr (string->list (car args)))) (options options))
+          (if (null? chars)
+              (lp (cdr args) options)
+              (let ((spec (assv-ref single (car chars))))
+                (cond
+                 ((not spec)
+                  (unrecognized-arg (string #\- (car chars))))
+                 ((assq-ref (cdr spec) 'value)
+                  (error "options with values not supported right now"))
+                 (else
+                  (lp* (cdr chars) (acons (car spec) #f options))))))))
+       (else (values (reverse options) args))))))
 
 (define (main args)
   (setlocale LC_ALL "")
-  (let* ((options (getopt args *option-grammar*))
-         (args (option-ref options '() '())))
-    (cond
-     ((option-ref options 'help #f)
-      (display-help)
-      (exit 0))
-     ((option-ref options 'version #f)
-      (display-version)
-      (exit 0))
-     ((or (equal? args '())
-          (equal? args '("list")))
-      (list-scripts))
-     ((find-script (car args))
-      => (lambda (mod)
-           (exit (apply (module-ref mod 'main) (cdr args)))))
-     (else
-      (format (current-error-port)
-              "guile-tools: unknown script ~s~%" (car args))
-      (format (current-error-port)
-              "Try `guile-tools --help' for more information.~%")
-      (exit 1)))))
+  (call-with-values (lambda () (getopt args *option-grammar*))
+    (lambda (options args)
+      (cond
+       ((assq 'help options)
+        (display-help)
+        (exit 0))
+       ((assq 'version options)
+        (display-version)
+        (exit 0))
+       ((or (equal? args '())
+            (equal? args '("list")))
+        (list-scripts))
+       ((find-script (car args))
+        => (lambda (mod)
+             (exit (apply (module-ref mod 'main) (cdr args)))))
+       (else
+        (format (current-error-port)
+                "guile-tools: unknown script ~s~%" (car args))
+        (format (current-error-port)
+                "Try `guile-tools --help' for more information.~%")
+        (exit 1))))))


hooks/post-receive
-- 
GNU Guile