From f4a76a315ad8f1f6f4dbdfbd2f030c6b299cb5a4 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 23 Jul 2011 18:24:16 +0200 Subject: [PATCH] add (scripts help) * meta/guild.in (display-version): Use (ice-9 command-line)'s version-etc. (main): Dispatch --help to guild help. * module/scripts/help.scm: New file, a copy of list.scm, but with a better name. * module/Makefile.am: Add help.scm to the list. * module/scripts/list.scm: Change to be an alias to "help". (list-scripts): Restore this API. --- meta/guild.in | 52 +++++++------------ module/Makefile.am | 1 + module/scripts/help.scm | 109 ++++++++++++++++++++++++++++++++++++++++ module/scripts/list.scm | 43 +++------------- 4 files changed, 137 insertions(+), 68 deletions(-) create mode 100644 module/scripts/help.scm diff --git a/meta/guild.in b/meta/guild.in index bb9c37e05..be4e5b5a3 100755 --- a/meta/guild.in +++ b/meta/guild.in @@ -25,6 +25,7 @@ exec guile $GUILE_FLAGS -e '(@@ (guild) main)' -s "$0" "$@" (define-module (guild) #:use-module (ice-9 getopt-long) + #:use-module (ice-9 command-line) #:autoload (ice-9 format) (format)) ;; Hack to provide scripts with the bug-report address. @@ -37,23 +38,11 @@ exec guile $GUILE_FLAGS -e '(@@ (guild) main)' -s "$0" "$@" '((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 -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))) + (version-etc "GNU Guile" + (effective-version) + #:command-name "guild" + #:license *LGPLv3+*)) (define (find-script s) (resolve-module (list 'scripts (string->symbol s)) #:ensure #f)) @@ -62,27 +51,24 @@ There is NO WARRANTY, to the extent permitted by law. (if (defined? 'setlocale) (setlocale LC_ALL "")) - (let ((options (getopt-long args *option-grammar* - #:stop-at-first-non-option #t))) + (let* ((options (getopt-long args *option-grammar* + #:stop-at-first-non-option #t)) + (args (option-ref options '() '()))) (cond ((option-ref options 'help #f) - (display-help) + (apply (module-ref (resolve-module '(scripts help)) 'main) args) (exit 0)) ((option-ref options 'version #f) (display-version) (exit 0)) + ((find-script (if (null? args) "help" (car args))) + => (lambda (mod) + (exit (apply (module-ref mod 'main) (if (null? args) + '() + (cdr args)))))) (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)))))))) + (format (current-error-port) + "guild: unknown script ~s~%" (car args)) + (format (current-error-port) + "Try `guild help' for more information.~%") + (exit 1))))) diff --git a/module/Makefile.am b/module/Makefile.am index 33d70bd95..0787f2004 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -153,6 +153,7 @@ SCRIPTS_SOURCES = \ scripts/doc-snarf.scm \ scripts/frisk.scm \ scripts/generate-autoload.scm \ + scripts/help.scm \ scripts/lint.scm \ scripts/list.scm \ scripts/punify.scm \ diff --git a/module/scripts/help.scm b/module/scripts/help.scm new file mode 100644 index 000000000..9bb6ace9c --- /dev/null +++ b/module/scripts/help.scm @@ -0,0 +1,109 @@ +;;; Help --- Show help on guild commands + +;;;; 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 + +;;; Commentary: + +;; Usage: help +;; +;; Show help for Guild scripts. + +;;; Code: + +(define-module (scripts help) + #:use-module (ice-9 format) + #:use-module ((srfi srfi-1) #:select (fold append-map))) + +(define %summary "Show a brief help message.") + + +(define (directory-files dir) + (if (and (file-exists? dir) (file-is-directory? dir)) + (let ((dir-stream (opendir dir))) + (let loop ((new (readdir dir-stream)) + (acc '())) + (if (eof-object? new) + (begin + (closedir dir-stream) + acc) + (loop (readdir dir-stream) + (if (or (string=? "." new) ; ignore + (string=? ".." new)) ; ignore + acc + (cons new acc)))))) + '())) + +(define (strip-extensions path) + (or-map (lambda (ext) + (and + (string-suffix? ext path) + ;; We really can't be adding e.g. ChangeLog-2008 to the set + ;; of runnable scripts, just because "" is a valid + ;; extension, by default. So hack around that here. + (not (string-null? ext)) + (substring path 0 + (- (string-length path) (string-length ext))))) + (append %load-compiled-extensions %load-extensions))) + +(define (unique l) + (cond ((null? l) l) + ((null? (cdr l)) l) + ((equal? (car l) (cadr l)) (unique (cdr l))) + (else (cons (car l) (unique (cdr l)))))) + +(define (find-submodules head) + (let ((shead (map symbol->string head))) + (unique + (sort + (append-map (lambda (path) + (fold (lambda (x rest) + (let ((stripped (strip-extensions x))) + (if stripped (cons stripped rest) rest))) + '() + (directory-files + (fold (lambda (x y) (in-vicinity y x)) path shead)))) + %load-path) + stringsymbol name))) + (mod (resolve-module modname #:ensure #f)) + (summary (and mod (and=> (module-variable mod '%summary) + variable-ref)))) + (if (and mod + (or all? + (let ((v (module-variable mod '%include-in-guild-list))) + (if v (variable-ref v) #t)))) + (if summary + (format #t " ~A ~23t~a\n" name summary) + (format #t " ~A\n" name))))) + (find-submodules '(scripts))))) diff --git a/module/scripts/list.scm b/module/scripts/list.scm index 55dbef264..0f1d715dd 100644 --- a/module/scripts/list.scm +++ b/module/scripts/list.scm @@ -26,12 +26,10 @@ ;;; Code: (define-module (scripts list) - #:use-module (ice-9 format) - #:use-module ((srfi srfi-1) #:select (fold append-map)) #:export (list-scripts)) (define %include-in-guild-list #f) -(define %summary "List available guild commands.") +(define %summary "An alias for \"help\".") (define (directory-files dir) @@ -82,36 +80,11 @@ %load-path) stringsymbol name))) - (mod (resolve-module modname #:ensure #f)) - (summary (and mod (and=> (module-variable mod '%summary) - variable-ref)))) - (if (and mod - (or all? - (let ((v (module-variable mod '%include-in-guild-list))) - (if v (variable-ref v) #t)))) - (if summary - (format #t " ~A ~23t~a\n" name summary) - (format #t " ~A\n" name))))) - (find-submodules '(scripts)))) - - (display "\ - -If COMMAND is \"list\" or omitted, display available scripts, otherwise -COMMAND is run with ARGS. -")) + (apply (@@ (scripts help) main) args))