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 . -# -AC_MSG_CHECKING(for struct timespec) -AC_CACHE_VAL(scm_cv_struct_timespec, - AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[ -#include -#if HAVE_PTHREAD_H -#include -#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 or .]) -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 ...))) -;; -;; open-input-pipe -;; +(if-supported + (use-modules (ice-9 popen)) -(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-input-pipe + ;; - ) + (with-test-prefix "open-input-pipe" -;; -;; open-output-pipe -;; + (pass-if-exception "no args" exception:wrong-num-args + (open-input-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))))) + (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")))) -;; -;; close-pipe -;; + ;; 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) -(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)))))) + ;; 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)))))))