mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-02 21:10:27 +02:00
fb3807793f
* meta/guile-tools: Instead of fixing scripts I should have been fixing the script runner. * module/scripts/compile.scm: * module/scripts/snarf-guile-m4-docs.scm: Fix to take rest args.
109 lines
3.7 KiB
Scheme
Executable file
109 lines
3.7 KiB
Scheme
Executable file
#!/bin/sh
|
|
# -*- scheme -*-
|
|
exec guile $GUILE_FLAGS -e '(@@ (guile-tools) main)' -s "$0" "$@"
|
|
!#
|
|
|
|
;;;; guile-tools --- running scripts bundled with Guile
|
|
;;;; Jim Blandy <jim@red-bean.com> --- September 1997
|
|
;;;;
|
|
;;;; Copyright (C) 1998, 2001, 2004, 2005, 2006, 2008, 2009 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 2.1 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))
|
|
|
|
;; 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)
|
|
(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))))))
|