meta/guile-tools

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