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 | ||
2b4b555b AW |
25 | (define-module (guile-tools)) |
26 | ||
27 | ;; We can't import srfi-1, unfortunately, as we are used early in the | |
28 | ;; boot process, before the srfi-1 shlib is built. | |
29 | ||
30 | (define (fold kons seed seq) | |
31 | (if (null? seq) | |
32 | seed | |
33 | (fold kons (kons (car seq) seed) (cdr seq)))) | |
6d66647d AW |
34 | |
35 | (define (help) | |
36 | (display "\ | |
37 | Usage: guile-tools --version | |
38 | guile-tools --help | |
39 | guile-tools PROGRAM [ARGS] | |
40 | ||
41 | If PROGRAM is \"list\" or omitted, display available scripts, otherwise | |
42 | PROGRAM is run with ARGS. | |
43 | ")) | |
44 | ||
45 | (define (directory-files dir) | |
46 | (if (and (file-exists? dir) (file-is-directory? dir)) | |
47 | (let ((dir-stream (opendir dir))) | |
48 | (let loop ((new (readdir dir-stream)) | |
49 | (acc '())) | |
50 | (if (eof-object? new) | |
51 | (begin | |
52 | (closedir dir-stream) | |
53 | acc) | |
54 | (loop (readdir dir-stream) | |
55 | (if (or (string=? "." new) ; ignore | |
56 | (string=? ".." new)) ; ignore | |
57 | acc | |
58 | (cons new acc)))))) | |
59 | '())) | |
60 | ||
61 | (define (strip-extensions path) | |
62 | (or-map (lambda (ext) | |
63 | (and | |
64 | (string-suffix? ext path) | |
65 | (substring path 0 | |
66 | (- (string-length path) (string-length ext))))) | |
67 | (append %load-extensions %load-compiled-extensions))) | |
68 | ||
69 | (define (unique l) | |
70 | (cond ((null? l) l) | |
71 | ((null? (cdr l)) l) | |
72 | ((equal? (car l) (cadr l)) (unique (cdr l))) | |
73 | (else (cons (car l) (unique (cdr l)))))) | |
74 | ||
75 | (define (find-submodules head) | |
76 | (let ((shead (map symbol->string head))) | |
77 | (unique | |
78 | (sort | |
79 | (append-map (lambda (path) | |
80 | (fold (lambda (x rest) | |
81 | (let ((stripped (strip-extensions x))) | |
82 | (if stripped (cons stripped rest) rest))) | |
83 | '() | |
84 | (directory-files | |
85 | (fold (lambda (x y) (in-vicinity y x)) path shead)))) | |
86 | %load-path) | |
87 | string<?)))) | |
88 | ||
89 | (define (list-scripts) | |
90 | (for-each (lambda (x) | |
91 | ;; would be nice to show a summary. | |
92 | (format #t "~A\n" x)) | |
93 | (find-submodules '(scripts)))) | |
94 | ||
95 | (define (find-script s) | |
96 | (let ((m (resolve-module (append '(scripts) (list (string->symbol s)))))) | |
97 | (and (module-public-interface m) | |
98 | m))) | |
99 | ||
100 | (define (main args) | |
101 | (if (or (equal? (cdr args) '()) | |
102 | (equal? (cdr args) '("list"))) | |
103 | (list-scripts) | |
104 | (let ((mod (find-script (cadr args)))) | |
105 | (exit ((module-ref mod 'main) (cdr args)))))) |