meta/guild.in

   1 #!/bin/sh
   2 # -*- scheme -*-
   3 exec guile $GUILE_FLAGS -e '(@@ (guild) main)' -s "$0" "$@"
   4 !#
   5
   6 ;;;; guild --- 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 (guild)
  27   #:use-module (ice-9 getopt-long)
  28   #:autoload (ice-9 format) (format))
  29
  30 ;; Hack to provide scripts with the bug-report address.
  31 (module-define! the-scm-module
  32                 '%guile-bug-report-address
  33                 "@PACKAGE_BUGREPORT@")
  34
  35
  36 (define *option-grammar*
  37   '((help (single-char #\h))
  38     (version (single-char #\v))))
  39
  40 (define (display-help)
  41   (display "\
  42 Usage: guild --version
  43        guild --help
  44        guild PROGRAM [ARGS]
  45
  46 If PROGRAM is \"list\" or omitted, display available scripts, otherwise
  47 PROGRAM is run with ARGS.
  48 "))
  49
  50 (define (display-version)
  51   (format #t "guild (GNU Guile ~A) ~A
  52 Copyright (C) 2010 Free Software Foundation, Inc.
  53 License LGPLv3+: GNU LGPL version 3 or later <http://gnu.org/licenses/lgpl.html>
  54 This is free software: you are free to change and redistribute it.
  55 There is NO WARRANTY, to the extent permitted by law.
  56 " (version) (effective-version)))
  57
  58 (define (find-script s)
  59   (resolve-module (list 'scripts (string->symbol s)) #:ensure #f))
  60
  61 (define (main args)
  62   (if (defined? 'setlocale)
  63       (setlocale LC_ALL ""))
  64
  65   (let ((options (getopt-long args *option-grammar*
  66                               #:stop-at-first-non-option #t)))
  67     (cond
  68      ((option-ref options 'help #f)
  69       (display-help)
  70       (exit 0))
  71      ((option-ref options 'version #f)
  72       (display-version)
  73       (exit 0))
  74      (else
  75       (let ((args (option-ref options '() '())))
  76         (cond ((find-script (if (null? args)
  77                                 "list"
  78                                 (car args)))
  79                => (lambda (mod)
  80                     (exit (apply (module-ref mod 'main) (if (null? args)
  81                                                             '()
  82                                                             (cdr args))))))
  83               (else
  84                (format (current-error-port)
  85                        "guild: unknown script ~s~%" (car args))
  86                (format (current-error-port)
  87                        "Try `guild --help' for more information.~%")
  88                (exit 1))))))))