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