rename `guile-tools' to `guild'

[bpt/guile.git] / meta / guild.in

diff --git a/meta/guild.in b/meta/guild.in
new file mode 100755 (executable)
index 0000000..bb9c37e
--- /dev/null
+++ b/meta/guild.in
@@ -0,0 +1,88 @@
+#!/bin/sh
+# -*- scheme -*-
+exec guile $GUILE_FLAGS -e '(@@ (guild) main)' -s "$0" "$@"
+!#
+
+;;;; guild --- running scripts bundled with Guile
+;;;; Andy Wingo <wingo@pobox.com> --- April 2009
+;;;; 
+;;;;   Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; 
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free
+;;;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (guild)
+  #:use-module (ice-9 getopt-long)
+  #:autoload (ice-9 format) (format))
+
+;; Hack to provide scripts with the bug-report address.
+(module-define! the-scm-module
+                '%guile-bug-report-address
+                "@PACKAGE_BUGREPORT@")
+
+
+(define *option-grammar*
+  '((help (single-char #\h))
+    (version (single-char #\v))))
+
+(define (display-help)
+  (display "\
+Usage: guild --version
+       guild --help
+       guild PROGRAM [ARGS]
+
+If PROGRAM is \"list\" or omitted, display available scripts, otherwise
+PROGRAM is run with ARGS.
+"))
+
+(define (display-version)
+  (format #t "guild (GNU Guile ~A) ~A
+Copyright (C) 2010 Free Software Foundation, Inc.
+License LGPLv3+: GNU LGPL version 3 or later <http://gnu.org/licenses/lgpl.html>
+This is free software: you are free to change and redistribute it.
+There is NO WARRANTY, to the extent permitted by law.
+" (version) (effective-version)))
+
+(define (find-script s)
+  (resolve-module (list 'scripts (string->symbol s)) #:ensure #f))
+
+(define (main args)
+  (if (defined? 'setlocale)
+      (setlocale LC_ALL ""))
+
+  (let ((options (getopt-long args *option-grammar*
+                              #:stop-at-first-non-option #t)))
+    (cond
+     ((option-ref options 'help #f)
+      (display-help)
+      (exit 0))
+     ((option-ref options 'version #f)
+      (display-version)
+      (exit 0))
+     (else
+      (let ((args (option-ref options '() '())))
+        (cond ((find-script (if (null? args)
+                                "list"
+                                (car args)))
+               => (lambda (mod)
+                    (exit (apply (module-ref mod 'main) (if (null? args)
+                                                            '()
+                                                            (cdr args))))))
+              (else
+               (format (current-error-port)
+                       "guild: unknown script ~s~%" (car args))
+               (format (current-error-port)
+                       "Try `guild --help' for more information.~%")
+               (exit 1))))))))