mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 11:40:18 +02:00
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.
This commit is contained in:
Andy Wingo
parent
a1a2ed5342
commit
f4a76a315a
4 changed files with 137 additions and 68 deletions
|
|
@ -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 <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)))
|
||||
(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)))))
|
||||
|
|
|
|||
|
|
@ -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 \
|
||||
|
|
|
|||
109
module/scripts/help.scm
Normal file
109
module/scripts/help.scm
Normal file
|
|
@ -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)
|
||||
string<?))))
|
||||
|
||||
(define (main . args)
|
||||
(display "\
|
||||
Usage: guild COMMAND [ARGS]
|
||||
|
||||
guild runs command-line scripts provided by GNU Guile and related
|
||||
programs. See \"Using Guile Tools\" in the Guile manual, for more
|
||||
information.
|
||||
|
||||
Commands:
|
||||
")
|
||||
|
||||
(let ((all? (or (equal? args '("--all"))
|
||||
(equal? args '("-a")))))
|
||||
(for-each
|
||||
(lambda (name)
|
||||
(let* ((modname `(scripts ,(string->symbol 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)))))
|
||||
|
|
@ -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)
|
||||
string<?))))
|
||||
|
||||
(define (list-scripts . args)
|
||||
(for-each (lambda (x)
|
||||
;; would be nice to show a summary.
|
||||
(format #t "~A\n" x))
|
||||
(find-submodules '(scripts))))
|
||||
|
||||
(define (main . args)
|
||||
(display "\
|
||||
Usage: guild COMMAND [ARGS]
|
||||
|
||||
guild runs command-line scripts provided by GNU Guile and related
|
||||
programs. See \"Using Guile Tools\" in the Guile manual, for more
|
||||
information.
|
||||
|
||||
Commands:
|
||||
")
|
||||
|
||||
(let ((all? (or (equal? args '("--all"))
|
||||
(equal? args '("-a")))))
|
||||
(for-each
|
||||
(lambda (name)
|
||||
(let* ((modname `(scripts ,(string->symbol 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))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue