[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-345-g86cf477
|
From: |
Mark H Weaver |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-345-g86cf477 |
|
Date: |
Sun, 31 Mar 2013 03:03:03 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=86cf4773ff94a128247d484e6d69786869f41ebc
The branch, master has been updated
via 86cf4773ff94a128247d484e6d69786869f41ebc (commit)
via b05257b9232e2ee631c28b15cace5981c4927446 (commit)
via beac49b8e129b28902f4b600e15aa3b92c9ce7fd (commit)
via df3d365a99311ecfe921d1dfd1848ff65112e572 (commit)
via 7e7c6f6a937005b08fffd5aeccdf992459b07137 (commit)
via 7bfbd2935fa812a0581df5b78c1a3b9836065f39 (commit)
via 0ddf484d3eeff9238cb4bf6f89d461748f42cb1c (commit)
from c33ecf96a41979be0af1d56a7e12ad7c1196f12b (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 86cf4773ff94a128247d484e6d69786869f41ebc
Merge: c33ecf9 b05257b
Author: Mark H Weaver <address@hidden>
Date: Sat Mar 30 22:56:27 2013 -0400
Merge remote-tracking branch 'origin/stable-2.0'
-----------------------------------------------------------------------
Summary of changes:
.gitignore | 4 +
configure.ac | 21 +---
doc/ref/api-options.texi | 8 +-
doc/ref/guile-invoke.texi | 3 +
doc/ref/posix.texi | 3 +-
doc/ref/srfi-modules.texi | 8 +-
lib/Makefile.am | 2 +-
libguile/posix.c | 1 +
m4/gnulib-cache.m4 | 3 +-
module/Makefile.am | 11 +-
module/ice-9/command-line.scm | 16 ++-
test-suite/tests/popen.test | 354 ++++++++++++++++++++--------------------
12 files changed, 225 insertions(+), 209 deletions(-)
diff --git a/.gitignore b/.gitignore
index 07601b9..90bacbe 100644
--- a/.gitignore
+++ b/.gitignore
@@ -152,3 +152,7 @@ INSTALL
/lib/wctype.h
/build-aux/ar-lib
/build-aux/test-driver
+*.trs
+/test-suite/standalone/test-smob-mark
+/test-suite/standalone/test-scm-values
+/test-suite/standalone/test-scm-to-latin1-string
diff --git a/configure.ac b/configure.ac
index e25635b..60aa49f 100644
--- a/configure.ac
+++ b/configure.ac
@@ -761,7 +761,8 @@ AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10
ctermid \
strcoll strcoll_l newlocale utimensat sched_getaffinity \
sched_setaffinity sendfile])
-AM_CONDITIONAL([HAVE_FORK], [test "x$ac_cv_func_fork" = "xyes"])
+AM_CONDITIONAL([BUILD_ICE_9_POPEN],
+ [test "x$enable_posix" = "xyes" && test "x$ac_cv_func_fork" = "xyes"])
# Reasons for testing:
# netdb.h - not in mingw
@@ -1302,24 +1303,6 @@ if test $scm_cv_struct_linger = yes; then
getsockopt and setsockopt system calls.])
fi
-
-# On mingw, struct timespec is in <pthread.h>.
-#
-AC_MSG_CHECKING(for struct timespec)
-AC_CACHE_VAL(scm_cv_struct_timespec,
- AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[
-#include <time.h>
-#if HAVE_PTHREAD_H
-#include <pthread.h>
-#endif]], [[struct timespec t; t.tv_nsec = 100]])],
- [scm_cv_struct_timespec="yes"],
- [scm_cv_struct_timespec="no"]))
-AC_MSG_RESULT($scm_cv_struct_timespec)
-if test $scm_cv_struct_timespec = yes; then
- AC_DEFINE([HAVE_STRUCT_TIMESPEC], 1,
- [Define this if your system defines struct timespec via either <time.h> or
<pthread.h>.])
-fi
-
#--------------------------------------------------------------------
#
# Flags for thread support
diff --git a/doc/ref/api-options.texi b/doc/ref/api-options.texi
index a1575c5..8fa4f98 100644
--- a/doc/ref/api-options.texi
+++ b/doc/ref/api-options.texi
@@ -1,6 +1,7 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005,
2006, 2008, 2009, 2010, 2011, 2012
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005,
2006,
address@hidden 2008, 2009, 2010, 2011, 2012, 2013
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -281,6 +282,11 @@ Databases}).
Indicates support for POSIX functions: @code{pipe}, @code{getgroups},
@code{kill}, @code{execl} and so on (@pxref{POSIX}).
address@hidden fork
+Indicates support for the POSIX @code{fork} function (@pxref{Processes,
address@hidden). This is a prerequisite for the @code{(ice-9
+popen)} module (@pxref{Pipes}).
+
@item random
Indicates availability of random number generation functions:
@code{random}, @code{copy-random-state}, @code{random-uniform} and so on
diff --git a/doc/ref/guile-invoke.texi b/doc/ref/guile-invoke.texi
index 15ca625..90922f2 100644
--- a/doc/ref/guile-invoke.texi
+++ b/doc/ref/guile-invoke.texi
@@ -71,6 +71,9 @@ before any directories in the @env{GUILE_LOAD_PATH}
environment
variable. Paths added here are @emph{not} in effect during execution of
the user's @file{.guile} file.
address@hidden -C @var{directory}
+Like @option{-L}, but adjusts the load path for @emph{compiled} files.
+
@item -x @var{extension}
Add @var{extension} to the front of Guile's load extension list
(@pxref{Load Paths, @code{%load-extensions}}). The specified extensions
diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index 950c351..e203090 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -2189,7 +2189,8 @@ controlling terminal. The return value is unspecified.
The following procedures are similar to the @code{popen} and
@code{pclose} system routines. The code is in a separate ``popen''
-module:
address@hidden module is only available on systems where the
address@hidden feature is provided (@pxref{Common Feature Symbols}).}:
@lisp
(use-modules (ice-9 popen))
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index 365341d..f0158d5 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -3844,7 +3844,7 @@ again. SRFI-41 can be made available with:
SRFI-41 Streams are based on two mutually-recursive abstract data types:
An object of the @code{stream} abstract data type is a promise that,
-when forced, is either @var{stream-null} or is an object of type
+when forced, is either @code{stream-null} or is an object of type
@code{stream-pair}. An object of the @code{stream-pair} abstract data
type contains a @code{stream-car} and a @code{stream-cdr}, which must be
a @code{stream}. The essential feature of streams is the systematic
@@ -3862,14 +3862,14 @@ stream, and is only forced on demand.
@subsubsection SRFI-41 Stream Primitives
This library provides eight operators: constructors for
address@hidden and @code{stream-pair}s, type predicates for streams
address@hidden and @code{stream-pair}s, type predicates for streams
and the two kinds of streams, accessors for both fields of a
@code{stream-pair}, and a lambda that creates procedures that return
streams.
@defvr {Scheme Variable} stream-null
A promise that, when forced, is a single object, distinguishable from
-all other objects, that represents the null stream. @var{stream-null}
+all other objects, that represents the null stream. @code{stream-null}
is immutable and unique.
@end defvr
@@ -4003,7 +4003,7 @@ Returns a newly-allocated stream containing the elements
from
Returns a newly-allocated stream containing in its elements the
characters on the port. If @var{port} is not given it defaults to the
current input port. The returned stream has finite length and is
-terminated by @var{stream-null}.
+terminated by @code{stream-null}.
It looks like one use of @code{port->stream} would be this:
diff --git a/lib/Makefile.am b/lib/Makefile.am
index c92a8ac..fdcd45d 100644
--- a/lib/Makefile.am
+++ b/lib/Makefile.am
@@ -21,7 +21,7 @@
# the same distribution terms as the rest of that program.
#
# Generated by gnulib-tool.
-# Reproduce by: gnulib-tool --import --dir=. --local-dir=gnulib-local
--lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests
--aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool
--macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen
autobuild bind byteswap canonicalize-lgpl ceil clock-time close connect dirfd
duplocale environ extensions flock floor fpieee frexp fstat full-read
full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt
git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib
iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions
lib-symbol-visibility libunistring listen localcharset locale log1p
maintainer-makefile malloc-gnu malloca nl_langinfo nproc open pipe-posix pipe2
poll putenv recv recvfrom regex rename select send sendto setenv setsockopt
shutdown socket stat-time stdlib strftime striconveh string sys_stat times
trunc verify vsnprintf warnings wchar
+# Reproduce by: gnulib-tool --import --dir=. --local-dir=gnulib-local
--lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests
--aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool
--macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen
autobuild bind byteswap canonicalize-lgpl ceil clock-time close connect dirfd
duplocale environ extensions flock floor fpieee frexp fstat full-read
full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt
git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib
iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions
lib-symbol-visibility libunistring listen localcharset locale log1p
maintainer-makefile malloc-gnu malloca nl_langinfo nproc open pipe-posix pipe2
poll putenv recv recvfrom regex rename select send sendto setenv setsockopt
shutdown socket stat-time stdlib strftime striconveh string sys_stat time times
trunc verify vsnprintf warnings wchar
AUTOMAKE_OPTIONS = 1.5 gnits subdir-objects
diff --git a/libguile/posix.c b/libguile/posix.c
index a6bf900..822599d 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -2337,6 +2337,7 @@ scm_init_posix ()
#include "libguile/posix.x"
#ifdef HAVE_FORK
+ scm_add_feature ("fork");
scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
"scm_init_popen",
(scm_t_extension_init_func) scm_init_popen,
diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4
index 310b6db..d6dd66d 100644
--- a/m4/gnulib-cache.m4
+++ b/m4/gnulib-cache.m4
@@ -27,7 +27,7 @@
# Specification in the form of a command-line invocation:
-# gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu
--source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests
--aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool
--macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen
autobuild bind byteswap canonicalize-lgpl ceil clock-time close connect dirfd
duplocale environ extensions flock floor fpieee frexp fstat full-read
full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt
git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib
iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions
lib-symbol-visibility libunistring listen localcharset locale log1p
maintainer-makefile malloc-gnu malloca nl_langinfo nproc open pipe-posix pipe2
poll putenv recv recvfrom regex rename select send sendto setenv setsockopt
shutdown socket stat-time stdlib strftime striconveh string sys_stat times
trunc verify vsnprintf warnings wchar
+# gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu
--source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests
--aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool
--macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen
autobuild bind byteswap canonicalize-lgpl ceil clock-time close connect dirfd
duplocale environ extensions flock floor fpieee frexp fstat full-read
full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt
git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib
iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions
lib-symbol-visibility libunistring listen localcharset locale log1p
maintainer-makefile malloc-gnu malloca nl_langinfo nproc open pipe-posix pipe2
poll putenv recv recvfrom regex rename select send sendto setenv setsockopt
shutdown socket stat-time stdlib strftime striconveh string sys_stat time times
trunc verify vsnprintf warnings wchar
# Specification in the form of a few gnulib-tool.m4 macro invocations:
gl_LOCAL_DIR([gnulib-local])
@@ -108,6 +108,7 @@ gl_MODULES([
striconveh
string
sys_stat
+ time
times
trunc
verify
diff --git a/module/Makefile.am b/module/Makefile.am
index 7f3c8f8..4daf7cf 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -158,7 +158,6 @@ BRAINFUCK_LANG_SOURCES = \
language/brainfuck/spec.scm
SCRIPTS_SOURCES = \
- scripts/autofrisk.scm \
scripts/compile.scm \
scripts/disassemble.scm \
scripts/display-commentary.scm \
@@ -174,7 +173,6 @@ SCRIPTS_SOURCES = \
scripts/use2dot.scm \
scripts/snarf-check-and-output-texi.scm \
scripts/summarize-guile-TODO.scm \
- scripts/scan-api.scm \
scripts/api-diff.scm \
scripts/read-rfc822.scm \
scripts/snarf-guile-m4-docs.scm
@@ -256,12 +254,17 @@ ICE_9_SOURCES = \
ice-9/serialize.scm \
ice-9/local-eval.scm
-if HAVE_FORK
+if BUILD_ICE_9_POPEN
# This functionality is missing on systems without `fork'---i.e., Windows.
ICE_9_SOURCES += ice-9/popen.scm
-endif HAVE_FORK
+# These modules rely on (ice-9 popen).
+SCRIPTS_SOURCES += \
+ scripts/autofrisk.scm \
+ scripts/scan-api.scm
+
+endif BUILD_ICE_9_POPEN
SRFI_SOURCES = \
srfi/srfi-2.scm \
diff --git a/module/ice-9/command-line.scm b/module/ice-9/command-line.scm
index 2aa50ec..0211b85 100644
--- a/module/ice-9/command-line.scm
+++ b/module/ice-9/command-line.scm
@@ -117,6 +117,7 @@ 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
+ -C DIRECTORY like -L, but for compiled files
-x EXTENSION add EXTENSION to the front of the load extensions
-l FILE load source code from FILE
-e FUNCTION after reading script, apply FUNCTION to
@@ -194,6 +195,7 @@ If FILE begins with `-' the -s switch is mandatory.
(script-cell #f)
(entry-point #f)
(user-load-path '())
+ (user-load-compiled-path '())
(user-extensions '())
(interactive? #t)
(inhibit-user-init? #f)
@@ -264,6 +266,14 @@ If FILE begins with `-' the -s switch is mandatory.
(parse (cdr args)
out))
+ ((string=? arg "-C") ; add to %load-compiled-path
+ (if (null? args)
+ (error "missing argument to `-C' switch"))
+ (set! user-load-compiled-path
+ (cons (car args) user-load-compiled-path))
+ (parse (cdr args)
+ out))
+
((string=? arg "-x") ; add to %load-extensions
(if (null? args)
(error "missing argument to `-x' switch"))
@@ -430,11 +440,15 @@ If FILE begins with `-' the -s switch is mandatory.
`(set! %load-extensions (cons ,ext %load-extensions)))
user-extensions)
- ;; Add the user-specified load path here, so it won't be in
+ ;; Add the user-specified load paths here, so they 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)
+ ,@(map (lambda (path)
+ `(set! %load-compiled-path
+ (cons ,path %load-compiled-path)))
+ user-load-compiled-path)
;; Put accumulated actions in their correct order.
,@(reverse! out)
diff --git a/test-suite/tests/popen.test b/test-suite/tests/popen.test
index bfd7da7..2818be0 100644
--- a/test-suite/tests/popen.test
+++ b/test-suite/tests/popen.test
@@ -1,25 +1,23 @@
;;;; popen.test --- exercise ice-9/popen.scm -*- scheme -*-
;;;;
-;;;; Copyright 2003, 2006, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright 2003, 2006, 2010, 2011, 2013 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 (test-suite test-ice-9-popen)
- #:use-module (test-suite lib)
- #:use-module (ice-9 popen))
-
+ #:use-module (test-suite lib))
;; read from PORT until eof is reached, return what's read as a string
(define (read-string-to-eof port)
@@ -37,176 +35,178 @@
thunk
restore-signals))
+(define-syntax-rule (if-supported body ...)
+ (if (provided? 'fork)
+ (begin body ...)))
+
+(if-supported
+ (use-modules (ice-9 popen))
+
+
+ ;;
+ ;; open-input-pipe
+ ;;
+
+ (with-test-prefix "open-input-pipe"
+
+ (pass-if-exception "no args" exception:wrong-num-args
+ (open-input-pipe))
+
+ (pass-if "port?"
+ (port? (open-input-pipe "echo hello")))
+
+ (pass-if "echo hello"
+ (string=? "hello\n" (read-string-to-eof (open-input-pipe "echo hello"))))
+
+ ;; exercise file descriptor setups when stdin is the same as stderr
+ (pass-if "stdin==stderr"
+ (let ((port (open-file "/dev/null" "r+")))
+ (with-input-from-port port
+ (lambda ()
+ (with-error-to-port port
+ (lambda ()
+ (open-input-pipe "echo hello"))))))
+ #t)
+
+ ;; exercise file descriptor setups when stdout is the same as stderr
+ (pass-if "stdout==stderr"
+ (let ((port (open-file "/dev/null" "r+")))
+ (with-output-to-port port
+ (lambda ()
+ (with-error-to-port port
+ (lambda ()
+ (open-input-pipe "echo hello"))))))
+ #t)
+
+ (pass-if "open-input-pipe process gets (current-input-port) as stdin"
+ (let* ((p2c (pipe))
+ (port (with-input-from-port (car p2c)
+ (lambda ()
+ (open-input-pipe "read line && echo $line")))))
+ (display "hello\n" (cdr p2c))
+ (force-output (cdr p2c))
+ (let ((result (eq? (read port) 'hello)))
+ (close-port (cdr p2c))
+ (close-pipe port)
+ result)))
+
+ ;; After the child closes stdout (which it indicates here by writing
+ ;; "closed" to stderr), the parent should see eof. In Guile 1.6.4
+ ;; and earlier a duplicate of stdout existed in the child, meaning
+ ;; eof was not seen.
+ ;;
+ ;; Note that the objective here is to test that the parent sees EOF
+ ;; while the child is still alive. (It is obvious that the parent
+ ;; must see EOF once the child has died.) The use of the `p2c'
+ ;; pipe, and `echo closed' and `read' in the child, allows us to be
+ ;; sure that we are testing what the parent sees at a point where
+ ;; the child has closed stdout but is still alive.
+ (pass-if "no duplicate"
+ (let* ((c2p (pipe))
+ (p2c (pipe))
+ (port (with-error-to-port (cdr c2p)
+ (lambda ()
+ (with-input-from-port (car p2c)
+ (lambda ()
+ (open-input-pipe
+ "exec 1>/dev/null; echo closed 1>&2; exec
2>/dev/null; read REPLY")))))))
+ (close-port (cdr c2p)) ;; write side
+ (let ((result (eof-object? (read-char port))))
+ (display "hello!\n" (cdr p2c))
+ (force-output (cdr p2c))
+ (close-pipe port)
+ result))))
+
+ ;;
+ ;; open-output-pipe
+ ;;
+
+ (with-test-prefix "open-output-pipe"
+
+ (pass-if-exception "no args" exception:wrong-num-args
+ (open-output-pipe))
+
+ (pass-if "port?"
+ (port? (open-output-pipe "exit 0")))
+
+ ;; exercise file descriptor setups when stdin is the same as stderr
+ (pass-if "stdin==stderr"
+ (let ((port (open-file "/dev/null" "r+")))
+ (with-input-from-port port
+ (lambda ()
+ (with-error-to-port port
+ (lambda ()
+ (open-output-pipe "exit 0"))))))
+ #t)
+
+ ;; exercise file descriptor setups when stdout is the same as stderr
+ (pass-if "stdout==stderr"
+ (let ((port (open-file "/dev/null" "r+")))
+ (with-output-to-port port
+ (lambda ()
+ (with-error-to-port port
+ (lambda ()
+ (open-output-pipe "exit 0"))))))
+ #t)
+
+ ;; After the child closes stdin (which it indicates here by writing
+ ;; "closed" to stderr), the parent should see a broken pipe. We
+ ;; setup to see this as EPIPE (rather than SIGPIPE). In Guile 1.6.4
+ ;; and earlier a duplicate of stdin existed in the child, preventing
+ ;; the broken pipe occurring.
+ ;;
+ ;; Note that the objective here is to test that the parent sees a
+ ;; broken pipe while the child is still alive. (It is obvious that
+ ;; the parent will see a broken pipe once the child has died.) The
+ ;; use of the `c2p' pipe, and the repeated `echo closed' in the
+ ;; child, allows us to be sure that we are testing what the parent
+ ;; sees at a point where the child has closed stdin but is still
+ ;; alive.
+ ;;
+ ;; Note that `with-epipe' must apply only to the parent and not to
+ ;; the child process; we rely on the child getting SIGPIPE, to
+ ;; terminate it (and avoid leaving a zombie).
+ (pass-if "no duplicate"
+ (let* ((c2p (pipe))
+ (port (with-error-to-port (cdr c2p)
+ (lambda ()
+ (open-output-pipe
+ (string-append "exec guile --no-auto-compile -s \""
+ (getenv "TEST_SUITE_DIR")
+ "/tests/popen-child.scm\""))))))
+ (close-port (cdr c2p)) ;; write side
+ (with-epipe
+ (lambda ()
+ (let ((result
+ (and (char? (read-char (car c2p))) ;; wait for child to do
its thing
+ (catch 'system-error
+ (lambda ()
+ (write-char #\x port)
+ (force-output port)
+ #f)
+ (lambda (key name fmt args errno-list)
+ (= (car errno-list) EPIPE))))))
+ ;; Now close our reading end of the pipe. This should give
+ ;; the child a broken pipe and so allow it to exit.
+ (close-port (car c2p))
+ (close-pipe port)
+ result))))))
+
+ ;;
+ ;; close-pipe
+ ;;
+
+ (with-test-prefix "close-pipe"
+
+ (pass-if-exception "no args" exception:wrong-num-args
+ (close-pipe))
-;;
-;; open-input-pipe
-;;
-
-(with-test-prefix "open-input-pipe"
-
- (pass-if-exception "no args" exception:wrong-num-args
- (open-input-pipe))
-
- (pass-if "port?"
- (port? (open-input-pipe "echo hello")))
-
- (pass-if "echo hello"
- (string=? "hello\n" (read-string-to-eof (open-input-pipe "echo hello"))))
-
- ;; exercise file descriptor setups when stdin is the same as stderr
- (pass-if "stdin==stderr"
- (let ((port (open-file "/dev/null" "r+")))
- (with-input-from-port port
- (lambda ()
- (with-error-to-port port
- (lambda ()
- (open-input-pipe "echo hello"))))))
- #t)
-
- ;; exercise file descriptor setups when stdout is the same as stderr
- (pass-if "stdout==stderr"
- (let ((port (open-file "/dev/null" "r+")))
- (with-output-to-port port
- (lambda ()
- (with-error-to-port port
- (lambda ()
- (open-input-pipe "echo hello"))))))
- #t)
-
- (pass-if "open-input-pipe process gets (current-input-port) as stdin"
- (let* ((p2c (pipe))
- (port (with-input-from-port (car p2c)
- (lambda ()
- (open-input-pipe "read line && echo $line")))))
- (display "hello\n" (cdr p2c))
- (force-output (cdr p2c))
- (let ((result (eq? (read port) 'hello)))
- (close-port (cdr p2c))
- (close-pipe port)
- result)))
-
- ;; After the child closes stdout (which it indicates here by writing
- ;; "closed" to stderr), the parent should see eof. In Guile 1.6.4
- ;; and earlier a duplicate of stdout existed in the child, meaning
- ;; eof was not seen.
- ;;
- ;; Note that the objective here is to test that the parent sees EOF
- ;; while the child is still alive. (It is obvious that the parent
- ;; must see EOF once the child has died.) The use of the `p2c'
- ;; pipe, and `echo closed' and `read' in the child, allows us to be
- ;; sure that we are testing what the parent sees at a point where
- ;; the child has closed stdout but is still alive.
- (pass-if "no duplicate"
- (let* ((c2p (pipe))
- (p2c (pipe))
- (port (with-error-to-port (cdr c2p)
- (lambda ()
- (with-input-from-port (car p2c)
- (lambda ()
- (open-input-pipe
- "exec 1>/dev/null; echo closed 1>&2; exec
2>/dev/null; read REPLY")))))))
- (close-port (cdr c2p)) ;; write side
- (let ((result (eof-object? (read-char port))))
- (display "hello!\n" (cdr p2c))
- (force-output (cdr p2c))
- (close-pipe port)
- result)))
-
- )
-
-;;
-;; open-output-pipe
-;;
-
-(with-test-prefix "open-output-pipe"
-
- (pass-if-exception "no args" exception:wrong-num-args
- (open-output-pipe))
-
- (pass-if "port?"
- (port? (open-output-pipe "exit 0")))
-
- ;; exercise file descriptor setups when stdin is the same as stderr
- (pass-if "stdin==stderr"
- (let ((port (open-file "/dev/null" "r+")))
- (with-input-from-port port
- (lambda ()
- (with-error-to-port port
- (lambda ()
- (open-output-pipe "exit 0"))))))
- #t)
-
- ;; exercise file descriptor setups when stdout is the same as stderr
- (pass-if "stdout==stderr"
- (let ((port (open-file "/dev/null" "r+")))
- (with-output-to-port port
- (lambda ()
- (with-error-to-port port
- (lambda ()
- (open-output-pipe "exit 0"))))))
- #t)
-
- ;; After the child closes stdin (which it indicates here by writing
- ;; "closed" to stderr), the parent should see a broken pipe. We
- ;; setup to see this as EPIPE (rather than SIGPIPE). In Guile 1.6.4
- ;; and earlier a duplicate of stdin existed in the child, preventing
- ;; the broken pipe occurring.
- ;;
- ;; Note that the objective here is to test that the parent sees a
- ;; broken pipe while the child is still alive. (It is obvious that
- ;; the parent will see a broken pipe once the child has died.) The
- ;; use of the `c2p' pipe, and the repeated `echo closed' in the
- ;; child, allows us to be sure that we are testing what the parent
- ;; sees at a point where the child has closed stdin but is still
- ;; alive.
- ;;
- ;; Note that `with-epipe' must apply only to the parent and not to
- ;; the child process; we rely on the child getting SIGPIPE, to
- ;; terminate it (and avoid leaving a zombie).
- (pass-if "no duplicate"
- (let* ((c2p (pipe))
- (port (with-error-to-port (cdr c2p)
- (lambda ()
- (open-output-pipe
- (string-append "exec guile --no-auto-compile -s \""
- (getenv "TEST_SUITE_DIR")
- "/tests/popen-child.scm\""))))))
- (close-port (cdr c2p)) ;; write side
- (with-epipe
- (lambda ()
- (let ((result
- (and (char? (read-char (car c2p))) ;; wait for child to do its
thing
- (catch 'system-error
- (lambda ()
- (write-char #\x port)
- (force-output port)
- #f)
- (lambda (key name fmt args errno-list)
- (= (car errno-list) EPIPE))))))
- ;; Now close our reading end of the pipe. This should give
- ;; the child a broken pipe and so allow it to exit.
- (close-port (car c2p))
- (close-pipe port)
- result)))))
-
- )
-
-;;
-;; close-pipe
-;;
-
-(with-test-prefix "close-pipe"
-
- (pass-if-exception "no args" exception:wrong-num-args
- (close-pipe))
-
- (pass-if "exit 0"
- (let ((st (close-pipe (open-output-pipe "exit 0"))))
- (and (status:exit-val st)
- (= 0 (status:exit-val st)))))
-
- (pass-if "exit 1"
- (let ((st (close-pipe (open-output-pipe "exit 1"))))
- (and (status:exit-val st)
- (= 1 (status:exit-val st))))))
+ (pass-if "exit 0"
+ (let ((st (close-pipe (open-output-pipe "exit 0"))))
+ (and (status:exit-val st)
+ (= 0 (status:exit-val st)))))
+ (pass-if "exit 1"
+ (let ((st (close-pipe (open-output-pipe "exit 1"))))
+ (and (status:exit-val st)
+ (= 1 (status:exit-val st)))))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-345-g86cf477,
Mark H Weaver <=