From 92a70bcf299632e5b19f86ab4629d4e24a09a7e1 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Thu, 27 Jan 2011 18:18:10 +0100
Subject: [PATCH] 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.
---
 meta/guile-tools.in | 117 ++++++++++++++++++++++++++++++++------------
 1 file changed, 85 insertions(+), 32 deletions(-)

diff --git a/meta/guile-tools.in b/meta/guile-tools.in
index cdcb6107a..a0822aefe 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))))))