summaryrefslogtreecommitdiff
path: root/module/scripts
diff options
context:
space:
mode:
authorNeil Jerram <neil@ossau.uklinux.net>2011-05-08 22:51:07 +0100
committerNeil Jerram <neil@ossau.uklinux.net>2011-05-26 17:58:18 +0100
commit9228f9eb956e8a7588c315239511fc4e08e16553 (patch)
tree040c49ed41815d9b01522a57a5e080da7c32e380 /module/scripts
parent6b4b4bfb0925adb2da66f4b49deb570da33c737d (diff)
downloadguile-9228f9eb956e8a7588c315239511fc4e08e16553.tar.gz
Reveal guile-tools's inner simplicity...
...by not using its own-rolled getopt, and moving the `list' function to a separate script * meta/guile-tools.in: Use (ice-9 getopt-long). (directory-files, strip-extensions, unique, find-submodules, list-scripts): Deleted (and moved to new `list.scm' file). (getopt): Deleted. (main): Use getopt-long. Default to calling the `list' script if no script is specified. * module/scripts/list.scm: New script. * module/Makefile.am (SCRIPTS_SOURCES): Add list.scm.
Diffstat (limited to 'module/scripts')
-rw-r--r--module/scripts/list.scm83
1 files changed, 83 insertions, 0 deletions
diff --git a/module/scripts/list.scm b/module/scripts/list.scm
new file mode 100644
index 000000000..046d8f5b8
--- /dev/null
+++ b/module/scripts/list.scm
@@ -0,0 +1,83 @@
+;;; List --- List scripts that can be invoked by guile-tools -*- coding: iso-8859-1 -*-
+
+;;;; Copyright (C) 2009, 2010, 2011 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
+
+;;; Commentary:
+
+;; Usage: list
+;;
+;; List scripts that can be invoked by guile-tools.
+
+;;; Code:
+
+(define-module (scripts list)
+ #:use-module ((srfi srfi-1) #:select (fold append-map))
+ #:export (list-scripts))
+
+
+(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))))))
+
+(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 . args)
+ (for-each (lambda (x)
+ ;; would be nice to show a summary.
+ (format #t "~A\n" x))
+ (find-submodules '(scripts))))
+
+(define main list-scripts)