module/scripts/list.scm

   1 ;;; List --- List scripts that can be invoked by guild  -*- coding: iso-8859-1 -*-
   2
   3 ;;;;    Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
   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 ;;
  24 ;; List scripts that can be invoked by guild.
  25
  26 ;;; Code:
  27
  28 (define-module (scripts list)
  29   #:use-module (srfi srfi-1)
  30   #:export (list-scripts))
  31
  32 (define %include-in-guild-list #f)
  33 (define %summary "An alias for \"help\".")
  34
  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)
  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))
  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
  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))))
  89
  90 (define (main . args)
  91   (apply (@@ (scripts help) main) args))