diff --git a/module/Makefile.am b/module/Makefile.am index 2685a3a63..42aff1833 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -181,6 +181,7 @@ ICE_9_SOURCES = \ ice-9/and-let-star.scm \ ice-9/binary-ports.scm \ ice-9/calling.scm \ + ice-9/command-line.scm \ ice-9/common-list.scm \ ice-9/control.scm \ ice-9/curried-definitions.scm \ diff --git a/module/ice-9/command-line.scm b/module/ice-9/command-line.scm new file mode 100644 index 000000000..e40006a82 --- /dev/null +++ b/module/ice-9/command-line.scm @@ -0,0 +1,416 @@ +;;; Parsing Guile's command-line + +;;; Copyright (C) 1994-1998, 2000-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 + +;;; Code: + +;;; +;;; Please be careful not to load up other modules in this file, unless +;;; they are explicitly requested. Loading modules currently imposes a +;;; speed penalty of a few stats, an mmap, and some allocation, which +;;; can range from 1 to 20ms, depending on the state of your disk cache. +;;; Since `compile-shell-switches' is called even for the most transient +;;; of command-line programs, we need to keep it lean. +;;; +;;; Generally speaking, the goal is for Guile to boot and execute simple +;;; expressions like "1" within 20ms or less, measured using system time +;;; from the time of the `guile' invocation to exit. +;;; + +(define-module (ice-9 command-line) + #:autoload (system vm vm) (set-default-vm-engine! set-vm-engine! the-vm) + #:export (compile-shell-switches + version-etc + *GPLv3+* + *LGPLv3+* + emit-bug-reporting-address)) + +;; An initial stab at i18n. +(define _ gettext) + +(define *GPLv3+* + (_ "License GPLv3+: GNU GPL 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.")) + +(define *LGPLv3+* + (_ "License LGPLv3+: GNU LGPL 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.")) + +;; Display the --version information in the +;; standard way: command and package names, package version, followed +;; by a short license notice and a list of up to 10 author names. +;; If COMMAND_NAME is NULL, the PACKAGE is asumed to be the name of +;; the program. The formats are therefore: +;; PACKAGE VERSION +;; or +;; COMMAND_NAME (PACKAGE) VERSION. +;; +;; Based on the version-etc gnulib module. +;; +(define* (version-etc package version #:key + (port (current-output-port)) + ;; FIXME: authors + (copyright-year 2011) + (copyright-holder "Free Software Foundation, Inc.") + (copyright (format #f "Copyright (C) ~a ~a" + copyright-year copyright-holder)) + (license *GPLv3+*) + command-name + packager packager-version) + (if command-name + (format port "~a (~a) ~a\n" command-name package version) + (format port "~a ~a\n" package version)) + + (if packager + (if packager-version + (format port (_ "Packaged by ~a (~a)\n") packager packager-version) + (format port (_ "Packaged by ~a\n") packager))) + + (display copyright port) + (newline port) + (newline port) + (display license port) + (newline port)) + + +;; Display the usual `Report bugs to' stanza. +;; +(define* (emit-bug-reporting-address package bug-address #:key + (port (current-output-port)) + (url (string-append + "http://www.gnu.org/software/" + package + "/")) + packager packager-bug-address) + (format port (_ "\nReport bugs to: ~a\n") bug-address) + (if (and packager packager-bug-address) + (format port (_ "Report ~a bugs to: ~a\n") packager packager-bug-address)) + (format port (_ "~a home page: <~a>\n") package url) + (format port + (_ "General help using GNU software: \n"))) + +(define *usage* + (_ "Evaluate Scheme code, interactively or from a script. + + [-s] FILE load Scheme source code from FILE, and exit + -c EXPR evalute Scheme expression EXPR, and exit + -- stop scanning arguments; run interactively + +The above switches stop argument processing, and pass all +remaining arguments as the value of (command-line). +If FILE begins with `-' the -s switch is mandatory. + + -L DIRECTORY add DIRECTORY to the front of the module load path + -x EXTENSION add EXTENSION to the front of the load extensions + -l FILE load Scheme source code from FILE + -e FUNCTION after reading script, apply FUNCTION to + command line arguments + -ds do -s script at this point + --debug start with debugging evaluator and backtraces + --no-debug start with normal evaluator + Default is to enable debugging for interactive + use, but not for `-s' and `-c'. + --auto-compile compile source files automatically + --no-auto-compile disable automatic source file compilation + Default is to enable auto-compilation of source + files. + --listen[=P] Listen on a local port or a path for REPL clients. + If P is not given, the default is local port 37146. + -q inhibit loading of user init file + --use-srfi=LS load SRFI modules for the SRFIs in LS, + which is a list of numbers like \"2,13,14\" + -h, --help display this help and exit + -v, --version display version information and exit + \\ read arguments from following script lines")) + + +(define* (shell-usage name fatal? #:optional fmt . args) + (let ((port (if fatal? + (current-error-port) + (current-output-port)))) + (if fmt + (apply format port fmt args)) + + (format port (_ "Usage: ~a [OPTION]... [FILE]...\n") name) + (display *usage* port) + (newline port) + + (emit-bug-reporting-address + "GNU Guile" "bug-guile@gnu.org" + #:port port + #:url "http://www.gnu.org/software/guile/" + #:packager (assq-ref %guile-build-info 'packager) + #:packager-bug-address + (assq-ref %guile-build-info 'packager-bug-address)) + + (if fatal? + (exit 1)))) + +(define (eval-string str) + (call-with-input-string + str + (lambda (port) + (let lp () + (let ((exp (read port))) + (if (not (eof-object? exp)) + (begin + (eval exp (current-module)) + (lp)))))))) + +(define* (compile-shell-switches args #:optional (usage-name "guile")) + (let ((arg0 "guile") + (do-script '()) + (entry-point #f) + (user-load-path '()) + (user-extensions '()) + (interactive? #t) + (inhibit-user-init? #f) + (turn-on-debugging? #f) + (turn-off-debugging? #f)) + + (define (error fmt . args) + (apply shell-usage usage-name #t fmt args)) + + (define (parse args out) + (cond + ((null? args) + (finish args out)) + (else + (let ((arg (car args)) + (args (cdr args))) + (cond + ((not (string-prefix? "-" arg)) ; foo + ;; If we specified the -ds option, do_script points to the + ;; cdr of an expression like (load #f) we replace the car + ;; (i.e., the #f) with the script name. + (if (pair? do-script) + (set-car! do-script arg)) + (set! arg0 arg) + (set! interactive? #f) + (finish args + (cons `(load ,arg) out))) + + ((string=? arg "-s") ; foo + (if (null? args) + (error "missing argument to `-s' switch")) + (set! arg0 (car args)) + (if (pair? do-script) + (set-car! do-script arg0)) + (set! interactive? #f) + (finish (cdr args) + (cons `(load ,arg0) out))) + + ((string=? arg "-c") ; evaluate expr + (if (null? args) + (error "missing argument to `-c' switch")) + (set! interactive? #f) + (finish (cdr args) + ;; Use our own eval-string to avoid loading (ice-9 + ;; eval-string), which loads the compiler. + (cons `((@@ (ice-9 command-line) eval-string) ,(car args)) + out))) + + ((string=? arg "--") ; end args go interactive + (finish args out)) + + ((string=? arg "-l") ; load a file + (if (null? args) + (error "missing argument to `-l' switch")) + (parse (cdr args) + (cons `(load ,(car args)) out))) + + ((string=? arg "-L") ; add to %load-path + (if (null? args) + (error "missing argument to `-L' switch")) + (set! user-load-path (cons (car args) user-load-path)) + (parse (cdr args) + out)) + + ((string=? arg "-x") ; add to %load-extensions + (if (null? args) + (error "missing argument to `-L' switch")) + (set! user-extensions (cons (car args) user-extensions)) + (parse (cdr args) + out)) + + ((string=? arg "-e") ; entry point + (if (null? args) + (error "missing argument to `-e' switch")) + (let* ((port (open-input-string (car args))) + (arg1 (read port)) + (arg2 (read port))) + ;; Recognize syntax of certain versions of guile 1.4 and + ;; transform to (@ MODULE-NAME FUNC). + (set! entry-point + (cond + ((not (eof-object? arg2)) + `(@ ,arg1 ,arg2)) + ((and (pair? arg1) + (not (memq (car arg1) '(@ @@))) + (and-map symbol? arg1)) + `(@ ,arg1 main)) + (else + arg1)))) + (parse (cdr args) + out)) + + ((string=? arg "-ds") ; do script here + ;; We put a dummy "load" expression, and let the -s put the + ;; filename in. + (if (pair? do-script) + (error "the -ds switch may only be specified once") + (set! do-script (list #f))) + (parse args + (cons `(load . ,do-script) out))) + + ((string=? arg "--debug") + (set! turn-on-debugging? #t) + (set! turn-off-debugging? #f) + (parse args out)) + + ((string=? arg "--no-debug") + (set! turn-off-debugging? #t) + (set! turn-on-debugging? #f) + (parse args out)) + + ;; Do auto-compile on/off now, because the form itself might + ;; need this decision. + ((string=? arg "--auto-compile") + (set! %load-should-auto-compile #t)) + + ((string=? arg "--no-auto-compile") + (set! %load-should-auto-compile #f)) + + ((string=? arg "-q") ; don't load user init + (set! inhibit-user-init? #t)) + + ((string-prefix? "--use-srfi=" arg) + (let ((srfis (map (lambda (x) + (let ((n (string->number x))) + (if (and n (exact? n) (integer? n) (>= n 0)) + n + (error "invalid SRFI specification")))) + (string-split (substring arg 11) #\,)))) + (if (null? srfis) + (error "invalid SRFI specification")) + (parse args + (cons `(use-srfis ',srfis) out)))) + + ((string=? arg "--listen") ; start a repl server + (parse args + (cons '(@@ (system repl server) (spawn-server)) out))) + + ((string-prefix? "--listen=" arg) ; start a repl server + (parse + args + (cons + (let ((where (substring arg 8))) + (cond + ((string->number where) ; --listen=PORT + => (lambda (port) + (if (and (integer? port) (exact? port) (>= port 0)) + (error "invalid port for --listen") + `(@@ (system repl server) + (spawn-server + (make-tcp-server-socket #:port ,port)))))) + ((string-prefix? "/" where) ; --listen=/PATH/TO/SOCKET + `(@@ (system repl server) + (spawn-server + (make-unix-domain-server-socket #:path ,where)))) + (else + (error "unknown argument to --listen")))) + out))) + + ((or (string=? arg "-h") (string=? arg "--help")) + (shell-usage usage-name #f) + (exit 0)) + + ((or (string=? arg "-v") (string=? arg "--version")) + (version-etc "GNU Guile" (version) + #:command-name "guile" + #:packager (assq-ref %guile-build-info 'packager) + #:packager-version + (assq-ref %guile-build-info 'packager-version)) + (exit 0)) + + (else + (error "Unrecognized switch ~a" arg))))))) + + (define (finish args out) + ;; Check to make sure the -ds got a -s. + (if (and (pair? do-script) (not (car do-script))) + (error "the `-ds' switch requires the use of `-s' as well")) + + ;; Make any remaining arguments available to the + ;; script/command/whatever. + (set-program-arguments (cons arg0 args)) + + ;; If debugging was requested, or we are interactive and debugging + ;; was not explicitly turned off, use the debug engine. + (if (or turn-on-debugging? + (and interactive? (not turn-off-debugging?))) + (begin + (set-default-vm-engine! 'debug) + (set-vm-engine! (the-vm) 'debug))) + + ;; Return this value. + `(;; It would be nice not to load up (ice-9 control), but the + ;; default-prompt-handler is nontrivial. + (@ (ice-9 control) %) + (begin + ;; If we didn't end with a -c or a -s and didn't supply a -q, load + ;; the user's customization file. + ,@(if (and interactive? (not inhibit-user-init?)) + '((load-user-init)) + '()) + + ;; Use-specified extensions. + ,@(map (lambda (ext) + `(set! %load-extensions (cons ,ext %load-extensions))) + user-extensions) + + ;; Add the user-specified load path here, so it won't be in + ;; effect during the loading of the user's customization file. + ,@(map (lambda (path) + `(set! %load-path (cons ,path %load-path))) + user-load-path) + + ;; Put accumulated actions in their correct order. + ,@(reverse! out) + + ;; Handle the `-e' switch, if it was specified. + ,@(if entry-point + `((,entry-point (command-line))) + '()) + ,(if interactive? + ;; If we didn't end with a -c or a -s, start the + ;; repl. + '((@ (ice-9 top-repl) top-repl)) + ;; Otherwise, after doing all the other actions + ;; prescribed by the command line, quit. + '(quit))))) + + (if (pair? args) + (begin + (set! arg0 (car args)) + (let ((slash (string-rindex arg0 #\/))) + (set! usage-name + (if slash (substring arg0 (1+ slash)) arg0))) + (parse (cdr args) '())) + (parse args '()))))