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 ;;;; Andy Wingo <wingo@pobox.com> --- April 2009
   8 ;;;;
   9 ;;;;    Copyright (C) 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 3 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
  23 ;;;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24 ;;;; Boston, MA 02110-1301 USA
  25
  26 (define-module (guile-tools))
  27
  28 ;; We can't import srfi-1, unfortunately, as we are used early in the
  29 ;; boot process, before the srfi-1 shlib is built.
  30
  31 (define (fold kons seed seq)
  32   (if (null? seq)
  33       seed
  34       (fold kons (kons (car seq) seed) (cdr seq))))
  35
  36 (define (help)
  37   (display "\
  38 Usage: guile-tools --version
  39        guile-tools --help
  40        guile-tools PROGRAM [ARGS]
  41
  42 If PROGRAM is \"list\" or omitted, display available scripts, otherwise
  43 PROGRAM is run with ARGS.
  44 "))
  45
  46 (define (directory-files dir)
  47   (if (and (file-exists? dir) (file-is-directory? dir))
  48       (let ((dir-stream (opendir dir)))
  49         (let loop ((new (readdir dir-stream))
  50                    (acc '()))
  51           (if (eof-object? new)
  52               (begin
  53                 (closedir dir-stream)
  54                 acc)
  55               (loop (readdir dir-stream)
  56                     (if (or (string=? "."  new)             ; ignore
  57                             (string=? ".." new))            ; ignore
  58                         acc
  59                         (cons new acc))))))
  60       '()))
  61
  62 (define (strip-extensions path)
  63   (or-map (lambda (ext)
  64             (and
  65              (string-suffix? ext path)
  66              (substring path 0
  67                         (- (string-length path) (string-length ext)))))
  68           (append %load-compiled-extensions %load-extensions)))
  69
  70 (define (unique l)
  71   (cond ((null? l) l)
  72         ((null? (cdr l)) l)
  73         ((equal? (car l) (cadr l)) (unique (cdr l)))
  74         (else (cons (car l) (unique (cdr l))))))
  75
  76 ;; for want of srfi-1
  77 (define (append-map f l)
  78   (apply append (map f l)))
  79
  80 (define (find-submodules head)
  81   (let ((shead (map symbol->string head)))
  82     (unique
  83      (sort
  84       (append-map (lambda (path)
  85                     (fold (lambda (x rest)
  86                             (let ((stripped (strip-extensions x)))
  87                               (if stripped (cons stripped rest) rest)))
  88                           '()
  89                           (directory-files
  90                            (fold (lambda (x y) (in-vicinity y x)) path shead))))
  91                   %load-path)
  92       string<?))))
  93
  94 (define (list-scripts)
  95   (for-each (lambda (x)
  96               ;; would be nice to show a summary.
  97               (format #t "~A\n" x))
  98             (find-submodules '(scripts))))
  99
 100 (define (find-script s)
 101   (let ((m (resolve-module (append '(scripts) (list (string->symbol s))))))
 102     (and (module-public-interface m)
 103          m)))
 104
 105 (define (main args)
 106   (if (or (equal? (cdr args) '())
 107           (equal? (cdr args) '("list")))
 108       (list-scripts)
 109       (let ((mod (find-script (cadr args))))
 110         (exit (apply (module-ref mod 'main) (cddr args))))))