summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.gitignore4
-rw-r--r--configure.ac21
-rw-r--r--doc/ref/api-options.texi8
-rw-r--r--doc/ref/guile-invoke.texi3
-rw-r--r--doc/ref/posix.texi3
-rw-r--r--doc/ref/srfi-modules.texi8
-rw-r--r--lib/Makefile.am2
-rw-r--r--libguile/posix.c1
-rw-r--r--m4/gnulib-cache.m43
-rw-r--r--module/Makefile.am11
-rw-r--r--module/ice-9/command-line.scm16
-rw-r--r--test-suite/tests/popen.test354
12 files changed, 225 insertions, 209 deletions
diff --git a/.gitignore b/.gitignore
index 07601b9ec..90bacbe7d 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 e25635b80..60aa49f31 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 a1575c5af..8fa4f98a5 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.
-@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2008, 2009, 2010, 2011, 2012
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
+@c 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}).
+@item fork
+Indicates support for the POSIX @code{fork} function (@pxref{Processes,
+@code{primitive-fork}}). 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 15ca625ec..90922f27d 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.
+@item -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 950c3519d..e20309000 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:
+module@footnote{This module is only available on systems where the
+@code{fork} 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 365341dde..f0158d5e8 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
-@var{stream-null} and @code{stream-pair}s, type predicates for streams
+@code{stream-null} 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 c92a8acf4..fdcd45d2f 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 a6bf90070..822599d9e 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 310b6db85..d6dd66d3d 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 7f3c8f8e0..4daf7cf51 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 2aa50ec80..0211b851c 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 bfd7da71c..2818be01b 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)))))))