HCoop / bpt / guile.git / blame
| Commit | Line | Data |
|---|---|---|
| 6d66647d AW |
1 | #!/bin/sh |
| 2 | # -*- scheme -*- | |
| 3 | exec guile $GUILE_FLAGS -e '(@@ (guile-tools) main)' -s "$0" "$@" | |
| 4 | !# | |
| 5 | ||
| 6 | ;;;; guile-tools --- running scripts bundled with Guile | |
| 7 | ;;;; Jim Blandy <jim@red-bean.com> --- September 1997 | |
| 8 | ;;;; | |
| 9 | ;;;; Copyright (C) 1998, 2001, 2004, 2005, 2006, 2008, 2009 Free Software Foundation, Inc. | |
| 10 | ;;;; | |
| 11 | ;;;; This library is free software; you can redistribute it and/or | |
| 12 | ;;;; modify it under the terms of the GNU Lesser General Public | |
| 13 | ;;;; License as published by the Free Software Foundation; either | |
| 14 | ;;;; version 2.1 of the License, or (at your option) any later version. | |
| 15 | ;;;; | |
| 16 | ;;;; This library is distributed in the hope that it will be useful, | |
| 17 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 18 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
| 19 | ;;;; Lesser General Public License for more details. | |
| 20 | ;;;; | |
| 21 | ;;;; You should have received a copy of the GNU Lesser General Public | |
| 22 | ;;;; License along with this library; if not, write to the Free Software | |
| 23 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
| 24 | ||
| 25 | (define-module (guile-tools) | |
| 26 | #:use-module (srfi srfi-1)) | |
| 27 | ||
| 28 | (define (help) | |
| 29 | (display "\ | |
| 30 | Usage: guile-tools --version | |
| 31 | guile-tools --help | |
| 32 | guile-tools PROGRAM [ARGS] | |
| 33 | ||
| 34 | If PROGRAM is \"list\" or omitted, display available scripts, otherwise | |
| 35 | PROGRAM is run with ARGS. | |
| 36 | ")) | |
| 37 | ||
| 38 | (define (directory-files dir) | |
| 39 | (if (and (file-exists? dir) (file-is-directory? dir)) | |
| 40 | (let ((dir-stream (opendir dir))) | |
| 41 | (let loop ((new (readdir dir-stream)) | |
| 42 | (acc '())) | |
| 43 | (if (eof-object? new) | |
| 44 | (begin | |
| 45 | (closedir dir-stream) | |
| 46 | acc) | |
| 47 | (loop (readdir dir-stream) | |
| 48 | (if (or (string=? "." new) ; ignore | |
| 49 | (string=? ".." new)) ; ignore | |
| 50 | acc | |
| 51 | (cons new acc)))))) | |
| 52 | '())) | |
| 53 | ||
| 54 | (define (strip-extensions path) | |
| 55 | (or-map (lambda (ext) | |
| 56 | (and | |
| 57 | (string-suffix? ext path) | |
| 58 | (substring path 0 | |
| 59 | (- (string-length path) (string-length ext))))) | |
| 60 | (append %load-extensions %load-compiled-extensions))) | |
| 61 | ||
| 62 | (define (unique l) | |
| 63 | (cond ((null? l) l) | |
| 64 | ((null? (cdr l)) l) | |
| 65 | ((equal? (car l) (cadr l)) (unique (cdr l))) | |
| 66 | (else (cons (car l) (unique (cdr l)))))) | |
| 67 | ||
| 68 | (define (find-submodules head) | |
| 69 | (let ((shead (map symbol->string head))) | |
| 70 | (unique | |
| 71 | (sort | |
| 72 | (append-map (lambda (path) | |
| 73 | (fold (lambda (x rest) | |
| 74 | (let ((stripped (strip-extensions x))) | |
| 75 | (if stripped (cons stripped rest) rest))) | |
| 76 | '() | |
| 77 | (directory-files | |
| 78 | (fold (lambda (x y) (in-vicinity y x)) path shead)))) | |
| 79 | %load-path) | |
| 80 | string<?)))) | |
| 81 | ||
| 82 | (define (list-scripts) | |
| 83 | (for-each (lambda (x) | |
| 84 | ;; would be nice to show a summary. | |
| 85 | (format #t "~A\n" x)) | |
| 86 | (find-submodules '(scripts)))) | |
| 87 | ||
| 88 | (define (find-script s) | |
| 89 | (let ((m (resolve-module (append '(scripts) (list (string->symbol s)))))) | |
| 90 | (and (module-public-interface m) | |
| 91 | m))) | |
| 92 | ||
| 93 | (define (main args) | |
| 94 | (if (or (equal? (cdr args) '()) | |
| 95 | (equal? (cdr args) '("list"))) | |
| 96 | (list-scripts) | |
| 97 | (let ((mod (find-script (cadr args)))) | |
| 98 | (exit ((module-ref mod 'main) (cdr args)))))) |