diff options
-rw-r--r-- | doc/ref/Makefile.am | 1 | ||||
-rw-r--r-- | doc/ref/mod-getopt-long.texi | 26 | ||||
-rw-r--r-- | doc/ref/script-getopt.texi | 93 | ||||
-rw-r--r-- | libguile/hashtab.c | 40 | ||||
-rw-r--r-- | libguile/r6rs-ports.c | 13 | ||||
-rwxr-xr-x | meta/guile-tools.in | 162 | ||||
-rw-r--r-- | module/Makefile.am | 1 | ||||
-rw-r--r-- | module/ice-9/boot-9.scm | 2 | ||||
-rw-r--r-- | module/ice-9/getopt-long.scm | 113 | ||||
-rw-r--r-- | module/rnrs/io/ports.scm | 8 | ||||
-rw-r--r-- | module/scripts/list.scm | 83 | ||||
-rw-r--r-- | test-suite/tests/getopt-long.test | 13 | ||||
-rw-r--r-- | test-suite/tests/r6rs-ports.test | 69 |
13 files changed, 265 insertions, 359 deletions
diff --git a/doc/ref/Makefile.am b/doc/ref/Makefile.am index 0359380c2..2ccf7dd22 100644 --- a/doc/ref/Makefile.am +++ b/doc/ref/Makefile.am @@ -67,7 +67,6 @@ guile_TEXINFOS = preface.texi \ api-deprecated.texi \ scheme-using.texi \ indices.texi \ - script-getopt.texi \ data-rep.texi \ repl-modules.texi \ srfi-modules.texi \ diff --git a/doc/ref/mod-getopt-long.texi b/doc/ref/mod-getopt-long.texi index 3d753df67..17402151a 100644 --- a/doc/ref/mod-getopt-long.texi +++ b/doc/ref/mod-getopt-long.texi @@ -13,8 +13,9 @@ The @code{(ice-9 getopt-long)} module exports two procedures: @itemize @bullet @item @code{getopt-long} takes a list of strings --- the command line -arguments --- and an @dfn{option specification}. It parses the command -line arguments according to the option specification and returns a data +arguments --- an @dfn{option specification}, and some optional keyword +parameters. It parses the command line arguments according to the +option specification and keyword parameters, and returns a data structure that encapsulates the results of the parsing. @item @@ -254,7 +255,7 @@ as ordinary argument strings. @node getopt-long Reference @subsection Reference Documentation for @code{getopt-long} -@deffn {Scheme Procedure} getopt-long args grammar +@deffn {Scheme Procedure} getopt-long args grammar [#:stop-at-first-non-option #t] Parse the command line given in @var{args} (which must be a list of strings) according to the option specification @var{grammar}. @@ -290,6 +291,13 @@ value, and throw an exception if it returns @code{#f}. @var{func} should be a procedure which accepts a string and returns a boolean value; you may need to use quasiquotes to get it into @var{grammar}. @end table + +The @code{#:stop-at-first-non-option} keyword, if specified with any +true value, tells @code{getopt-long} to stop when it gets to the first +non-option in the command line. That is, at the first word which is +neither an option itself, nor the value of an option. Everything in the +command line from that word onwards will be returned as non-option +arguments. @end deffn @code{getopt-long}'s @var{args} parameter is expected to be a list of @@ -323,6 +331,18 @@ happen using the long option @code{--opt=@var{value}} syntax). An option predicate fails. @end itemize +@code{#:stop-at-first-non-option} is useful for command line invocations +like @code{guile-tools [--help | --version] [script [script-options]]} +and @code{cvs [general-options] command [command-options]}, where there +are options at two levels: some generic and understood by the outer +command, and some that are specific to the particular script or command +being invoked. To use @code{getopt-long} in such cases, you would call +it twice: firstly with @code{#:stop-at-first-non-option #t}, so as to +parse any generic options and identify the wanted script or sub-command; +secondly, and after trimming off the initial generic command words, with +a script- or sub-command-specific option grammar, so as to process those +specific options. + @node option-ref Reference @subsection Reference Documentation for @code{option-ref} diff --git a/doc/ref/script-getopt.texi b/doc/ref/script-getopt.texi deleted file mode 100644 index c7bb0d439..000000000 --- a/doc/ref/script-getopt.texi +++ /dev/null @@ -1,93 +0,0 @@ -@c -*-texinfo-*- -@c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004 -@c Free Software Foundation, Inc. -@c See the file guile.texi for copying conditions. - -@node Command Line Handling -@section Handling Command Line Options and Arguments - -@c This chapter was written and contributed by Martin Grabmueller. - -The ability to accept and handle command line arguments is very -important when writing Guile scripts to solve particular problems, such -as extracting information from text files or interfacing with existing -command line applications. This chapter describes how Guile makes -command line arguments available to a Guile script, and the utilities -that Guile provides to help with the processing of command line -arguments. - -When a Guile script is invoked, Guile makes the command line arguments -accessible via the procedure @code{command-line}, which returns the -arguments as a list of strings. - -For example, if the script - -@example -#! /usr/local/bin/guile -s -!# -(write (command-line)) -(newline) -@end example - -@noindent -is saved in a file @file{cmdline-test.scm} and invoked using the command -line @code{./cmdline-test.scm bar.txt -o foo -frumple grob}, the output -is - -@example -("./cmdline-test.scm" "bar.txt" "-o" "foo" "-frumple" "grob") -@end example - -If the script invocation includes a @code{-e} option, specifying a -procedure to call after loading the script, Guile will call that -procedure with @code{(command-line)} as its argument. So a script that -uses @code{-e} doesn't need to refer explicitly to @code{command-line} -in its code. For example, the script above would have identical -behaviour if it was written instead like this: - -@example -#! /usr/local/bin/guile \ --e main -s -!# -(define (main args) - (write args) - (newline)) -@end example - -(Note the use of the meta switch @code{\} so that the script invocation -can include more than one Guile option: @xref{The Meta Switch}.) - -These scripts use the @code{#!} POSIX convention so that they can be -executed using their own file names directly, as in the example command -line @code{./cmdline-test.scm bar.txt -o foo -frumple grob}. But they -can also be executed by typing out the implied Guile command line in -full, as in: - -@example -$ guile -s ./cmdline-test.scm bar.txt -o foo -frumple grob -@end example - -@noindent -or - -@example -$ guile -e main -s ./cmdline-test2.scm bar.txt -o foo -frumple grob -@end example - -Even when a script is invoked using this longer form, the arguments that -the script receives are the same as if it had been invoked using the -short form. Guile ensures that the @code{(command-line)} or @code{-e} -arguments are independent of how the script is invoked, by stripping off -the arguments that Guile itself processes. - -A script is free to parse and handle its command line arguments in any -way that it chooses. Where the set of possible options and arguments is -complex, however, it can get tricky to extract all the options, check -the validity of given arguments, and so on. This task can be greatly -simplified by taking advantage of the module @code{(ice-9 getopt-long)}, -which is distributed with Guile, @xref{getopt-long}. - -@c Local Variables: -@c TeX-master: "guile.texi" -@c End: diff --git a/libguile/hashtab.c b/libguile/hashtab.c index d70799380..440738c11 100644 --- a/libguile/hashtab.c +++ b/libguile/hashtab.c @@ -1377,40 +1377,20 @@ scm_internal_hash_fold (scm_t_hash_fold_fn fn, void *closure, n = SCM_SIMPLE_VECTOR_LENGTH (buckets); for (i = 0; i < n; ++i) { - SCM prev, ls; + SCM ls, handle; - for (prev = SCM_BOOL_F, ls = SCM_SIMPLE_VECTOR_REF (buckets, i); - !scm_is_null (ls); - prev = ls, ls = SCM_CDR (ls)) + for (ls = SCM_SIMPLE_VECTOR_REF (buckets, i); !scm_is_null (ls); + ls = SCM_CDR (ls)) { - SCM handle; - - if (!scm_is_pair (ls)) - SCM_WRONG_TYPE_ARG (SCM_ARG3, buckets); - handle = SCM_CAR (ls); - if (!scm_is_pair (handle)) - SCM_WRONG_TYPE_ARG (SCM_ARG3, buckets); - if (SCM_HASHTABLE_WEAK_P (table)) - { - if (SCM_WEAK_PAIR_DELETED_P (handle)) - { - /* We hit a weak pair whose car/cdr has become - unreachable: unlink it from the bucket. */ - if (scm_is_true (prev)) - SCM_SETCDR (prev, SCM_CDR (ls)); - else - SCM_SIMPLE_VECTOR_SET (buckets, i, SCM_CDR (ls)); - - /* Update the item count. */ - SCM_HASHTABLE_DECREMENT (table); - - continue; - } - } - - result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result); + if (SCM_HASHTABLE_WEAK_P (table) && SCM_WEAK_PAIR_DELETED_P (handle)) + /* Don't try to unlink this weak pair, as we're not within + the allocation lock. Instead rely on + vacuum_weak_hash_table to do its job. */ + continue; + else + result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result); } } diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index 308f17a94..bf146ef15 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -1179,12 +1179,21 @@ tp_flush (SCM port) scm_t_port *c_port = SCM_PTAB_ENTRY (port); size_t count = c_port->write_pos - c_port->write_buf; - scm_c_write (binary_port, c_port->write_buf, count); + /* As the runtime will try to flush all ports upon exit, we test for + the underlying port still being open here. Otherwise, when you + would explicitly close the underlying port and the transcoded port + still had data outstanding, you'd get an exception on Guile exit. + + We just throw away the data when the underlying port is closed. */ + + if (SCM_OPOUTPORTP (binary_port)) + scm_c_write (binary_port, c_port->write_buf, count); c_port->write_pos = c_port->write_buf; c_port->rw_active = SCM_PORT_NEITHER; - scm_force_output (binary_port); + if (SCM_OPOUTPORTP (binary_port)) + scm_force_output (binary_port); } static int diff --git a/meta/guile-tools.in b/meta/guile-tools.in index 7f156ffd9..2f335b8f7 100755 --- a/meta/guile-tools.in +++ b/meta/guile-tools.in @@ -24,7 +24,7 @@ exec guile $GUILE_FLAGS -e '(@@ (guile-tools) main)' -s "$0" "$@" ;;;; Boston, MA 02110-1301 USA (define-module (guile-tools) - #:use-module ((srfi srfi-1) #:select (fold append-map)) + #:use-module (ice-9 getopt-long) #:autoload (ice-9 format) (format)) ;; Hack to provide scripts with the bug-report address. @@ -55,146 +55,34 @@ 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 (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) - (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 (list-scripts) - (for-each (lambda (x) - ;; would be nice to show a summary. - (format #t "~A\n" x)) - (find-submodules '(scripts)))) - (define (find-script s) (resolve-module (list 'scripts (string->symbol s)) #:ensure #f)) -(define (getopt args grammar) - (define (fail) - (format (current-error-port) - "Try `guile-tools --help' for more information.~%") - (exit 1)) - - (define (unrecognized-arg arg) - (format (current-error-port) - "guile-tools: unrecognized option: `~a'~%" arg) - (fail)) - - (define (unexpected-value sym val) - (format (current-error-port) - "guile-tools: option `--~a' does not take an argument (given ~s)~%" - sym val) - (fail)) - - (define (single-char-table grammar) - (cond - ((null? grammar) '()) - ((assq 'single-char (cdar grammar)) - => (lambda (form) - (acons (cadr form) (car grammar) - (single-char-table (cdr grammar))))) - (else - (single-char-table (cdr grammar))))) - - (let ((single (single-char-table grammar))) - (let lp ((args (cdr args)) (options '())) - (cond - ((or (null? args) (equal? (car args) "-")) - (values (reverse options) args)) - ((equal? (car args) "--") - (values (reverse options) (cdr args))) - ((string-prefix? "--" (car args)) - (let* ((str (car args)) - (eq (string-index str #\= 2)) - (sym (string->symbol - (substring str 2 (or eq (string-length str))))) - (val (and eq (substring str (1+ eq)))) - (spec (assq sym grammar))) - (cond - ((not spec) - (unrecognized-arg (substring str 0 (or eq (string-length str))))) - (val - ;; no values for now - (unexpected-value sym val)) - ((assq-ref (cdr spec) 'value) - (error "options with values not supported right now")) - (else - (lp (cdr args) (acons sym #f options)))))) - ((string-prefix? "-" (car args)) - (let lp* ((chars (cdr (string->list (car args)))) (options options)) - (if (null? chars) - (lp (cdr args) options) - (let ((spec (assv-ref single (car chars)))) - (cond - ((not spec) - (unrecognized-arg (string #\- (car chars)))) - ((assq-ref (cdr spec) 'value) - (error "options with values not supported right now")) - (else - (lp* (cdr chars) (acons (car spec) #f options)))))))) - (else (values (reverse options) args)))))) - (define (main args) (if (defined? 'setlocale) (setlocale LC_ALL "")) - (call-with-values (lambda () (getopt args *option-grammar*)) - (lambda (options args) - (cond - ((assq 'help options) - (display-help) - (exit 0)) - ((assq 'version options) - (display-version) - (exit 0)) - ((or (equal? args '()) - (equal? args '("list"))) - (list-scripts)) - ((find-script (car args)) - => (lambda (mod) - (exit (apply (module-ref mod 'main) (cdr args))))) - (else - (format (current-error-port) - "guile-tools: unknown script ~s~%" (car args)) - (format (current-error-port) - "Try `guile-tools --help' for more information.~%") - (exit 1)))))) + (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) + "guile-tools: unknown script ~s~%" (car args)) + (format (current-error-port) + "Try `guile-tools --help' for more information.~%") + (exit 1)))))))) diff --git a/module/Makefile.am b/module/Makefile.am index 42aff1833..ddd46749f 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -155,6 +155,7 @@ SCRIPTS_SOURCES = \ scripts/frisk.scm \ scripts/generate-autoload.scm \ scripts/lint.scm \ + scripts/list.scm \ scripts/punify.scm \ scripts/read-scheme-source.scm \ scripts/read-text-outline.scm \ diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 0493de514..7c9e3c5eb 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -682,7 +682,7 @@ If there is no handler at all, Guile prints an error and then exits." (let ((filename (or (cadr source) "<unnamed port>")) (line (caddr source)) (col (cdddr source))) - (format port "~a:~a:~a: " filename line col)) + (format port "~a:~a:~a: " filename (1+ line) col)) (format port "ERROR: ")))) (set! set-exception-printer! diff --git a/module/ice-9/getopt-long.scm b/module/ice-9/getopt-long.scm index 1b170b494..12f8c94c3 100644 --- a/module/ice-9/getopt-long.scm +++ b/module/ice-9/getopt-long.scm @@ -161,6 +161,7 @@ #:use-module (srfi srfi-9) #:use-module (ice-9 match) #:use-module (ice-9 regex) + #:use-module (ice-9 optargs) #:export (getopt-long option-ref)) (define %program-name (make-fluid)) @@ -179,8 +180,6 @@ option-spec? (name option-spec->name set-option-spec-name!) - (value - option-spec->value set-option-spec-value!) (required? option-spec->required? set-option-spec-required?!) (option-spec->single-char @@ -228,33 +227,12 @@ (define long-opt-no-value-rx (make-regexp "^--([^=]+)$")) (define long-opt-with-value-rx (make-regexp "^--([^=]+)=(.*)")) -(define (expand-clumped-singles opt-ls) - ;; example: ("--xyz" "-abc5d") => ("--xyz" "-a" "-b" "-c" "5d") - (let loop ((opt-ls opt-ls) (ret-ls '())) - (cond ((null? opt-ls) - (reverse ret-ls)) ;;; retval - ((regexp-exec short-opt-rx (car opt-ls)) - => (lambda (match) - (let ((singles (reverse - (map (lambda (c) - (string-append "-" (make-string 1 c))) - (string->list - (match:substring match 1))))) - (extra (match:substring match 2))) - (loop (cdr opt-ls) - (append (if (string=? "" extra) - singles - (cons extra singles)) - ret-ls))))) - (else (loop (cdr opt-ls) - (cons (car opt-ls) ret-ls)))))) - (define (looks-like-an-option string) (or (regexp-exec short-opt-rx string) (regexp-exec long-opt-with-value-rx string) (regexp-exec long-opt-no-value-rx string))) -(define (process-options specs argument-ls) +(define (process-options specs argument-ls stop-at-first-non-option) ;; Use SPECS to scan ARGUMENT-LS; return (FOUND . ETC). ;; FOUND is an unordered list of option specs for found options, while ETC ;; is an order-maintained list of elements in ARGUMENT-LS that are neither @@ -266,32 +244,22 @@ (cons (make-string 1 (option-spec->single-char spec)) spec)) (remove-if-not option-spec->single-char specs)))) - (let loop ((argument-ls argument-ls) (found '()) (etc '())) + (let loop ((unclumped 0) (argument-ls argument-ls) (found '()) (etc '())) (define (eat! spec ls) - (define (val!loop val n-ls n-found n-etc) - (set-option-spec-value! - spec - ;; handle multiple occurrances - (cond ((option-spec->value spec) - => (lambda (cur) - ((if (list? cur) cons list) - val cur))) - (else val))) - (loop n-ls n-found n-etc)) (cond ((eq? 'optional (option-spec->value-policy spec)) (if (or (null? ls) (looks-like-an-option (car ls))) - (val!loop #t ls (cons spec found) etc) - (val!loop (car ls) (cdr ls) (cons spec found) etc))) + (loop (- unclumped 1) ls (acons spec #t found) etc) + (loop (- unclumped 2) (cdr ls) (acons spec (car ls) found) etc))) ((eq? #t (option-spec->value-policy spec)) (if (or (null? ls) (looks-like-an-option (car ls))) (fatal-error "option must be specified with argument: --~a" (option-spec->name spec)) - (val!loop (car ls) (cdr ls) (cons spec found) etc))) + (loop (- unclumped 2) (cdr ls) (acons spec (car ls) found) etc))) (else - (val!loop #t ls (cons spec found) etc)))) + (loop (- unclumped 1) ls (acons spec #t found) etc)))) (match argument-ls (() @@ -300,10 +268,24 @@ (cond ((regexp-exec short-opt-rx opt) => (lambda (match) - (let* ((c (match:substring match 1)) - (spec (or (assoc-ref sc-idx c) - (fatal-error "no such option: -~a" c)))) - (eat! spec rest)))) + (if (> unclumped 0) + ;; Next option is known not to be clumped. + (let* ((c (match:substring match 1)) + (spec (or (assoc-ref sc-idx c) + (fatal-error "no such option: -~a" c)))) + (eat! spec rest)) + ;; Expand a clumped group of short options. + (let* ((extra (match:substring match 2)) + (unclumped-opts + (append (map (lambda (c) + (string-append "-" (make-string 1 c))) + (string->list + (match:substring match 1))) + (if (string=? "" extra) '() (list extra))))) + (loop (length unclumped-opts) + (append unclumped-opts rest) + found + etc))))) ((regexp-exec long-opt-no-value-rx opt) => (lambda (match) (let* ((opt (match:substring match 1)) @@ -319,10 +301,14 @@ (eat! spec (cons (match:substring match 2) rest)) (fatal-error "option does not support argument: --~a" opt))))) + ((and stop-at-first-non-option + (<= unclumped 0)) + (cons found (append (reverse etc) argument-ls))) (else - (loop rest found (cons opt etc))))))))) + (loop (- unclumped 1) rest found (cons opt etc))))))))) -(define (getopt-long program-arguments option-desc-list) +(define* (getopt-long program-arguments option-desc-list + #:key stop-at-first-non-option) "Process options, handling both long and short options, similar to the glibc function 'getopt_long'. PROGRAM-ARGUMENTS should be a value similar to what (program-arguments) returns. OPTION-DESC-LIST is a @@ -356,44 +342,27 @@ to add a `single-char' clause to the option description." (with-fluids ((%program-name (car program-arguments))) (let* ((specifications (map parse-option-spec option-desc-list)) (pair (split-arg-list (cdr program-arguments))) - (split-ls (expand-clumped-singles (car pair))) + (split-ls (car pair)) (non-split-ls (cdr pair)) - (found/etc (process-options specifications split-ls)) + (found/etc (process-options specifications split-ls + stop-at-first-non-option)) (found (car found/etc)) (rest-ls (append (cdr found/etc) non-split-ls))) (for-each (lambda (spec) (let ((name (option-spec->name spec)) - (val (option-spec->value spec))) + (val (assq-ref found spec))) (and (option-spec->required? spec) - (or (memq spec found) + (or val (fatal-error "option must be specified: --~a" name))) - (and (memq spec found) - (eq? #t (option-spec->value-policy spec)) - (or val - (fatal-error - "option must be specified with argument: --~a" - name))) (let ((pred (option-spec->predicate spec))) (and pred (pred name val))))) specifications) - (cons (cons '() rest-ls) - (let ((multi-count (map (lambda (desc) - (cons (car desc) 0)) - option-desc-list))) - (map (lambda (spec) - (let ((name (string->symbol (option-spec->name spec)))) - (cons name - ;; handle multiple occurrances - (let ((maybe-ls (option-spec->value spec))) - (if (list? maybe-ls) - (let* ((look (assq name multi-count)) - (idx (cdr look)) - (val (list-ref maybe-ls idx))) - (set-cdr! look (1+ idx)) ; ugh! - val) - maybe-ls))))) - found)))))) + (for-each (lambda (spec+val) + (set-car! spec+val + (string->symbol (option-spec->name (car spec+val))))) + found) + (cons (cons '() rest-ls) found)))) (define (option-ref options key default) "Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not found. diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm index 4ae01be68..246e46b39 100644 --- a/module/rnrs/io/ports.scm +++ b/module/rnrs/io/ports.scm @@ -311,7 +311,9 @@ read from/written to in @var{port}." (buffer-mode (buffer-mode block)) maybe-transcoder) (let ((port (with-i/o-filename-conditions filename - (lambda () (open filename O_RDONLY))))) + (lambda () + (with-fluids ((%default-port-encoding #f)) + (open filename O_RDONLY)))))) (cond (maybe-transcoder (set-port-encoding! port (transcoder-codec maybe-transcoder)))) port)) @@ -340,7 +342,9 @@ as a string, and a thunk to retrieve the characters associated with that port." 0 O_EXCL))) (port (with-i/o-filename-conditions filename - (lambda () (open filename flags))))) + (lambda () + (with-fluids ((%default-port-encoding #f)) + (open filename flags)))))) (cond (maybe-transcoder (set-port-encoding! port (transcoder-codec maybe-transcoder)))) port)) diff --git a/module/scripts/list.scm b/module/scripts/list.scm new file mode 100644 index 000000000..046d8f5b8 --- /dev/null +++ b/module/scripts/list.scm @@ -0,0 +1,83 @@ +;;; List --- List scripts that can be invoked by guile-tools -*- coding: iso-8859-1 -*- + +;;;; 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: list +;; +;; List scripts that can be invoked by guile-tools. + +;;; Code: + +(define-module (scripts list) + #:use-module ((srfi srfi-1) #:select (fold append-map)) + #:export (list-scripts)) + + +(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) + (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 (list-scripts . args) + (for-each (lambda (x) + ;; would be nice to show a summary. + (format #t "~A\n" x)) + (find-submodules '(scripts)))) + +(define main list-scripts) diff --git a/test-suite/tests/getopt-long.test b/test-suite/tests/getopt-long.test index d7f518482..4ae604883 100644 --- a/test-suite/tests/getopt-long.test +++ b/test-suite/tests/getopt-long.test @@ -252,7 +252,7 @@ ) -(with-test-prefix "multiple occurrances" +(with-test-prefix "multiple occurrences" (define (test9 . args) (equal? (getopt-long (cons "foo" args) @@ -288,4 +288,15 @@ ) +(with-test-prefix "stop-at-first-non-option" + + (pass-if "guile-tools compile example" + (equal? (getopt-long '("guile-tools" "compile" "-Wformat" "eval.scm" "-o" "eval.go") + '((help (single-char #\h)) + (version (single-char #\v))) + #:stop-at-first-non-option #t) + '((() "compile" "-Wformat" "eval.scm" "-o" "eval.go")))) + + ) + ;;; getopt-long.test ends here diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test index 7a382b75b..f3e8c2c5d 100644 --- a/test-suite/tests/r6rs-ports.test +++ b/test-suite/tests/r6rs-ports.test @@ -27,12 +27,6 @@ #:use-module (rnrs exceptions) #:use-module (rnrs bytevectors)) -;;; All these tests assume Guile 1.8's port system, where characters are -;;; treated as octets. - -;; Set the default encoding of future ports to be Latin-1. -(fluid-set! %default-port-encoding #f) - (define-syntax pass-if-condition (syntax-rules () ((_ name predicate body0 body ...) @@ -72,6 +66,12 @@ (lambda () #t)) ;; close-port "rw"))) +(define (call-with-bytevector-output-port/transcoded transcoder receiver) + (call-with-bytevector-output-port + (lambda (bv-port) + (call-with-port (transcoded-port bv-port transcoder) + receiver)))) + (with-test-prefix "7.2.5 End-of-File Object" @@ -316,6 +316,22 @@ (with-test-prefix "7.2.7 Input Ports" + (let ((filename (test-file)) + (contents (string->utf8 "GNU λ"))) + + ;; Create file + (call-with-output-file filename + (lambda (port) (put-bytevector port contents))) + + (pass-if "open-file-input-port [opens binary port]" + (with-fluids ((%default-port-encoding "UTF-8")) + (call-with-port (open-file-input-port filename) + (lambda (port) + (and (binary-port? port) + (bytevector=? contents (get-bytevector-all port))))))) + + (delete-file filename)) + ;; This section appears here so that it can use the binary input ;; primitives. @@ -463,11 +479,12 @@ (with-test-prefix "8.2.10 Output ports" (let ((filename (test-file))) - (pass-if "open-file-output-port [opens binary port]" - (call-with-port (open-file-output-port filename) - (lambda (port) - (put-bytevector port '#vu8(1 2 3)) - (binary-port? port)))) + (with-fluids ((%default-port-encoding "UTF-8")) + (pass-if "open-file-output-port [opens binary port]" + (call-with-port (open-file-output-port filename) + (lambda (port) + (put-bytevector port '#vu8(1 2 3)) + (binary-port? port))))) (pass-if-condition "open-file-output-port [exception: already-exists]" i/o-file-already-exists-error? @@ -620,11 +637,9 @@ (let ((s "Hello\nÄÖÜ")) (bytevector=? (string->utf8 s) - (call-with-bytevector-output-port - (lambda (bv-port) - (call-with-port (transcoded-port bv-port (make-transcoder (utf-8-codec))) - (lambda (utf8-port) - (put-string utf8-port s)))))))) + (call-with-bytevector-output-port/transcoded (make-transcoder (utf-8-codec)) + (lambda (utf8-port) + (put-string utf8-port s)))))) (pass-if "transcoded-port [input]" (let ((s "Hello\nÄÖÜ")) @@ -720,6 +735,11 @@ (pass-if-condition "get-datum" i/o-read-error? (get-datum (make-failing-port))))) +(define (encoding-error-predicate char) + (lambda (c) + (and (i/o-encoding-error? c) + (char=? char (i/o-encoding-error-char c))))) + (with-test-prefix "8.2.12 Textual Output" (with-test-prefix "write error" @@ -728,7 +748,22 @@ (pass-if-condition "put-string" i/o-write-error? (put-string (make-failing-port) "Hello World!")) (pass-if-condition "put-datum" i/o-write-error? - (put-datum (make-failing-port) '(hello world!))))) + (put-datum (make-failing-port) '(hello world!)))) + (with-test-prefix "encoding error" + (pass-if-condition "put-char" (encoding-error-predicate #\λ) + (call-with-bytevector-output-port/transcoded + (make-transcoder (latin-1-codec) + (native-eol-style) + (error-handling-mode raise)) + (lambda (port) + (put-char port #\λ)))) + (pass-if-condition "put-string" (encoding-error-predicate #\λ) + (call-with-bytevector-output-port/transcoded + (make-transcoder (latin-1-codec) + (native-eol-style) + (error-handling-mode raise)) + (lambda (port) + (put-string port "FooλBar")))))) (with-test-prefix "8.3 Simple I/O" (with-test-prefix "read error" |