meta/guile-tools.in

   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, 2010, 2011 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   #:use-module ((srfi srfi-1) #:select (fold append-map)))
  28
  29 ;; Hack to provide scripts with the bug-report address.
  30 (module-define! the-scm-module
  31                 '%guile-bug-report-address
  32                 "@PACKAGE_BUGREPORT@")
  33
  34
  35 (define (display-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 (display-version)
  46   (format #t "guile-tools (GNU Guile ~A) ~A
  47 Copyright (C) 2010 Free Software Foundation, Inc.
  48 License LGPLv3+: GNU LGPL version 3 or later <http://gnu.org/licenses/lgpl.html>
  49 This is free software: you are free to change and redistribute it.
  50 There is NO WARRANTY, to the extent permitted by law.
  51 " (version) (effective-version)))
  52
  53 (define (directory-files dir)
  54   (if (and (file-exists? dir) (file-is-directory? dir))
  55       (let ((dir-stream (opendir dir)))
  56         (let loop ((new (readdir dir-stream))
  57                    (acc '()))
  58           (if (eof-object? new)
  59               (begin
  60                 (closedir dir-stream)
  61                 acc)
  62               (loop (readdir dir-stream)
  63                     (if (or (string=? "."  new)             ; ignore
  64                             (string=? ".." new))            ; ignore
  65                         acc
  66                         (cons new acc))))))
  67       '()))
  68
  69 (define (strip-extensions path)
  70   (or-map (lambda (ext)
  71             (and
  72              (string-suffix? ext path)
  73              (substring path 0
  74                         (- (string-length path) (string-length ext)))))
  75           (append %load-compiled-extensions %load-extensions)))
  76
  77 (define (unique l)
  78   (cond ((null? l) l)
  79         ((null? (cdr l)) l)
  80         ((equal? (car l) (cadr l)) (unique (cdr l)))
  81         (else (cons (car l) (unique (cdr l))))))
  82
  83 (define (find-submodules head)
  84   (let ((shead (map symbol->string head)))
  85     (unique
  86      (sort
  87       (append-map (lambda (path)
  88                     (fold (lambda (x rest)
  89                             (let ((stripped (strip-extensions x)))
  90                               (if stripped (cons stripped rest) rest)))
  91                           '()
  92                           (directory-files
  93                            (fold (lambda (x y) (in-vicinity y x)) path shead))))
  94                   %load-path)
  95       string<?))))
  96
  97 (define (list-scripts)
  98   (for-each (lambda (x)
  99               ;; would be nice to show a summary.
 100               (format #t "~A\n" x))
 101             (find-submodules '(scripts))))
 102
 103 (define (find-script s)
 104   (let ((m (resolve-module (append '(scripts) (list (string->symbol s))))))
 105     (and (module-public-interface m)
 106          m)))
 107
 108 (define (main args)
 109   (setlocale LC_ALL "")
 110   (cond
 111    ((or (equal? (cdr args) '())
 112         (equal? (cdr args) '("list")))
 113     (list-scripts))
 114    ((string-prefix? "-" (cadr args))
 115     (let ((option (cadr args)))
 116       (cond
 117        ((equal? option "--help")
 118         (display-help)
 119         (exit 0))
 120        ((equal? option "--version")
 121         (display-version)
 122         (exit 0))
 123        (else
 124         (format (current-error-port) "Unrecognized option: ~an" option)
 125         (exit 1)))))
 126    (else
 127     (let ((mod (find-script (cadr args))))
 128       (exit (apply (module-ref mod 'main) (cddr args)))))))