mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-22 11:34:09 +02:00
Code Activity

guile-tools uses getopt-long

Browse source 
* meta/guile-tools.in: Use getopt-long.
This commit is contained in:
Andy Wingo 2011-01-27 11:15:01 +01:00
parent a27b0f3682
commit 38a73781e6
1 changed files with 33 additions and 20 deletions
Download patch file Download diff file Expand all files Collapse all files

41
meta/guile-tools.in
View file

@ -24,7 +24,9 @@ exec guile $GUILE_FLAGS -e '(@@ (guile-tools) main)' -s "$0" "$@"
;;;; Boston, MA 02110-1301 USA ;;;; Boston, MA 02110-1301 USA
(define-module (guile-tools) (define-module (guile-tools)
#:use-module ((srfi srfi-1) #:select (fold append-map))) #:use-module ((srfi srfi-1) #:select (fold append-map))
#:autoload (ice-9 format) (format)
#:use-module (ice-9 getopt-long))
;; Hack to provide scripts with the bug-report address. ;; Hack to provide scripts with the bug-report address.
(module-define! the-scm-module (module-define! the-scm-module
@ -32,6 +34,10 @@ exec guile $GUILE_FLAGS -e '(@@ (guile-tools) main)' -s "$0" "$@"
"@PACKAGE_BUGREPORT@") "@PACKAGE_BUGREPORT@")
(define *option-grammar*
'((help (single-char #\h))
(version (single-char #\v))))
(define (display-help) (define (display-help)
(display "\ (display "\
Usage: guile-tools --version Usage: guile-tools --version
@ -105,24 +111,31 @@ There is NO WARRANTY, to the extent permitted by law.
(and (module-public-interface m) (and (module-public-interface m)
m))) m)))
(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 (main args) (define (main args)
(setlocale LC_ALL "") (setlocale LC_ALL "")
(let* ((options (getopt args *option-grammar*))
(args (option-ref options '() '())))
(cond (cond
((or (equal? (cdr args) '()) ((option-ref options 'help #f)
(equal? (cdr args) '("list")))
(list-scripts))
((string-prefix? "-" (cadr args))
(let ((option (cadr args)))
(cond
((equal? option "--help")
(display-help) (display-help)
(exit 0)) (exit 0))
((equal? option "--version") ((option-ref options 'version #f)
(display-version) (display-version)
(exit 0)) (exit 0))
((or (equal? args '())
(equal? args '("list")))
(list-scripts))
(else (else
(format (current-error-port) "Unrecognized option: ~an" option) (let ((mod (find-script (car args))))
(exit 1))))) (exit (apply (module-ref mod 'main) (cdr args))))))))
(else
(let ((mod (find-script (cadr args))))
(exit (apply (module-ref mod 'main) (cddr args)))))))