mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-21 19:20:21 +02:00
Code Activity

fix guile-tools getopt

Browse source 
* meta/guile-tools.in (getopt): Define a local version of getopt that
  stops parsing options when it sees a non-option.
This commit is contained in:
Andy Wingo 2011-01-27 18:18:10 +01:00
parent bc312c45dd
commit 92a70bcf29
1 changed files with 85 additions and 32 deletions
Download patch file Download diff file Expand all files Collapse all files

117
meta/guile-tools.in
View file

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