1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
|
#!/bin/sh
# -*- scheme -*-
exec guile $GUILE_FLAGS -e '(@@ (guile-tools) main)' -s "$0" "$@"
!#
;;;; guile-tools --- running scripts bundled with Guile
;;;; Andy Wingo <wingo@pobox.com> --- April 2009
;;;;
;;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free
;;;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
(define-module (guile-tools))
;; Hack to provide scripts with the bug-report address.
(module-define! the-scm-module
'%guile-bug-report-address
"@PACKAGE_BUGREPORT@")
;; We can't import srfi-1, unfortunately, as we are used early in the
;; boot process, before the srfi-1 shlib is built.
(define (fold kons seed seq)
(if (null? seq)
seed
(fold kons (kons (car seq) seed) (cdr seq))))
(define (help)
(display "\
Usage: guile-tools --version
guile-tools --help
guile-tools PROGRAM [ARGS]
If PROGRAM is \"list\" or omitted, display available scripts, otherwise
PROGRAM is run with ARGS.
"))
(define (directory-files dir)
(if (and (file-exists? dir) (file-is-directory? dir))
(let ((dir-stream (opendir dir)))
(let loop ((new (readdir dir-stream))
(acc '()))
(if (eof-object? new)
(begin
(closedir dir-stream)
acc)
(loop (readdir dir-stream)
(if (or (string=? "." new) ; ignore
(string=? ".." new)) ; ignore
acc
(cons new acc))))))
'()))
(define (strip-extensions path)
(or-map (lambda (ext)
(and
(string-suffix? ext path)
(substring path 0
(- (string-length path) (string-length ext)))))
(append %load-compiled-extensions %load-extensions)))
(define (unique l)
(cond ((null? l) l)
((null? (cdr l)) l)
((equal? (car l) (cadr l)) (unique (cdr l)))
(else (cons (car l) (unique (cdr l))))))
;; for want of srfi-1
(define (append-map f l)
(apply append (map f l)))
(define (find-submodules head)
(let ((shead (map symbol->string head)))
(unique
(sort
(append-map (lambda (path)
(fold (lambda (x rest)
(let ((stripped (strip-extensions x)))
(if stripped (cons stripped rest) rest)))
'()
(directory-files
(fold (lambda (x y) (in-vicinity y x)) path shead))))
%load-path)
string<?))))
(define (list-scripts)
(for-each (lambda (x)
;; would be nice to show a summary.
(format #t "~A\n" x))
(find-submodules '(scripts))))
(define (find-script s)
(let ((m (resolve-module (append '(scripts) (list (string->symbol s))))))
(and (module-public-interface m)
m)))
(define (main args)
(setlocale LC_ALL "")
(if (or (equal? (cdr args) '())
(equal? (cdr args) '("list")))
(list-scripts)
(let ((mod (find-script (cadr args))))
(exit (apply (module-ref mod 'main) (cddr args))))))
|
