Commit | Line | Data |
---|---|---|
b8b06598 | 1 | ;;; List --- List scripts that can be invoked by guild -*- coding: iso-8859-1 -*- |
9228f9eb | 2 | |
f5e772b2 | 3 | ;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc. |
9228f9eb NJ |
4 | ;;;; |
5 | ;;;; This library is free software; you can redistribute it and/or | |
6 | ;;;; modify it under the terms of the GNU Lesser General Public | |
7 | ;;;; License as published by the Free Software Foundation; either | |
8 | ;;;; version 3 of the License, or (at your option) any later version. | |
9 | ;;;; | |
10 | ;;;; This library is distributed in the hope that it will be useful, | |
11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | ;;;; Lesser General Public License for more details. | |
14 | ;;;; | |
15 | ;;;; You should have received a copy of the GNU Lesser General Public | |
16 | ;;;; License along with this library; if not, write to the Free | |
17 | ;;;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor, | |
18 | ;;;; Boston, MA 02110-1301 USA | |
19 | ||
20 | ;;; Commentary: | |
21 | ||
22 | ;; Usage: list | |
23 | ;; | |
b8b06598 | 24 | ;; List scripts that can be invoked by guild. |
9228f9eb NJ |
25 | |
26 | ;;; Code: | |
27 | ||
28 | (define-module (scripts list) | |
f5e772b2 | 29 | #:use-module (srfi srfi-1) |
9228f9eb NJ |
30 | #:export (list-scripts)) |
31 | ||
a1a2ed53 | 32 | (define %include-in-guild-list #f) |
f4a76a31 | 33 | (define %summary "An alias for \"help\".") |
a1a2ed53 | 34 | |
9228f9eb NJ |
35 | \f |
36 | (define (directory-files dir) | |
37 | (if (and (file-exists? dir) (file-is-directory? dir)) | |
38 | (let ((dir-stream (opendir dir))) | |
39 | (let loop ((new (readdir dir-stream)) | |
40 | (acc '())) | |
41 | (if (eof-object? new) | |
42 | (begin | |
43 | (closedir dir-stream) | |
44 | acc) | |
45 | (loop (readdir dir-stream) | |
46 | (if (or (string=? "." new) ; ignore | |
47 | (string=? ".." new)) ; ignore | |
48 | acc | |
49 | (cons new acc)))))) | |
50 | '())) | |
51 | ||
52 | (define (strip-extensions path) | |
53 | (or-map (lambda (ext) | |
54 | (and | |
55 | (string-suffix? ext path) | |
5d48015a AW |
56 | ;; We really can't be adding e.g. ChangeLog-2008 to the set |
57 | ;; of runnable scripts, just because "" is a valid | |
58 | ;; extension, by default. So hack around that here. | |
59 | (not (string-null? ext)) | |
9228f9eb NJ |
60 | (substring path 0 |
61 | (- (string-length path) (string-length ext))))) | |
62 | (append %load-compiled-extensions %load-extensions))) | |
63 | ||
64 | (define (unique l) | |
65 | (cond ((null? l) l) | |
66 | ((null? (cdr l)) l) | |
67 | ((equal? (car l) (cadr l)) (unique (cdr l))) | |
68 | (else (cons (car l) (unique (cdr l)))))) | |
69 | ||
70 | (define (find-submodules head) | |
71 | (let ((shead (map symbol->string head))) | |
72 | (unique | |
73 | (sort | |
74 | (append-map (lambda (path) | |
75 | (fold (lambda (x rest) | |
76 | (let ((stripped (strip-extensions x))) | |
77 | (if stripped (cons stripped rest) rest))) | |
78 | '() | |
79 | (directory-files | |
80 | (fold (lambda (x y) (in-vicinity y x)) path shead)))) | |
81 | %load-path) | |
82 | string<?)))) | |
83 | ||
f4a76a31 AW |
84 | (define (list-scripts . args) |
85 | (for-each (lambda (x) | |
86 | ;; would be nice to show a summary. | |
87 | (format #t "~A\n" x)) | |
88 | (find-submodules '(scripts)))) | |
5d48015a | 89 | |
f4a76a31 AW |
90 | (define (main . args) |
91 | (apply (@@ (scripts help) main) args)) |