mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-23 13:00:34 +02:00
Code Activity

Only run tests that require fork if it is provided

Browse source 
* test-suite/tests/00-repl-server.test (call-with-repl-server): throw if no fork provided
* test-suite/tests/00-socket.test (primitive-fork-if-available): new help procedure
  (bind/sockaddr, AF_UNIX/SOCK_STREAM): use helper func
* test-suite/tests/ports.test ("pipe, fdopen, and line buffering"): throw if no fork provided
This commit is contained in:
Michael Gran 2017-04-04 07:33:41 -07:00
parent 39339c9fb9
commit 685ca33e2e
3 changed files with 13 additions and 7 deletions
Download patch file Download diff file Expand all files Collapse all files

4
test-suite/tests/00-repl-server.test
View file

@ -32,8 +32,8 @@ socket connected to that server."
(false-if-exception (false-if-exception
(delete-file (sockaddr:path sockaddr))) (delete-file (sockaddr:path sockaddr)))
;; The REPL server requires threads. ;; The REPL server requires thread. The test requires fork.
(unless (provided? 'threads) (unless (and (provided? 'threads) (provided? 'fork))
(throw 'unsupported)) (throw 'unsupported))
(match (primitive-fork) (match (primitive-fork)

12
test-suite/tests/00-socket.test
View file

@ -1,7 +1,7 @@
;;;; 00-socket.test --- test socket functions -*- scheme -*- ;;;; 00-socket.test --- test socket functions -*- scheme -*-
;;;; ;;;;
;;;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, ;;;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010,
;;;; 2011, 2012, 2013, 2014 Free Software Foundation, Inc. ;;;; 2011, 2012, 2013, 2014, 2017 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -161,6 +161,10 @@
(number->string (current-time)) "-" (number->string (current-time)) "-"
(number->string (random 100000)))) (number->string (random 100000))))
(define (primitive-fork-if-available)
(if (not (provided? 'fork))
-1
(primitive-fork)))
(if (defined? 'AF_UNIX) (if (defined? 'AF_UNIX)
(with-test-prefix "AF_UNIX/SOCK_DGRAM" (with-test-prefix "AF_UNIX/SOCK_DGRAM"
@ -261,7 +265,7 @@
(force-output (current-output-port)) (force-output (current-output-port))
(force-output (current-error-port)) (force-output (current-error-port))
(if server-listening? (if server-listening?
(let ((pid (primitive-fork))) (let ((pid (primitive-fork-if-available)))
;; Spawn a server process. ;; Spawn a server process.
(case pid (case pid
((-1) (throw 'unresolved)) ((-1) (throw 'unresolved))
@ -341,7 +345,7 @@
(force-output (current-output-port)) (force-output (current-output-port))
(force-output (current-error-port)) (force-output (current-error-port))
(if server-listening? (if server-listening?
(let ((pid (primitive-fork))) (let ((pid (primitive-fork-if-available)))
;; Spawn a server process. ;; Spawn a server process.
(case pid (case pid
((-1) (throw 'unresolved)) ((-1) (throw 'unresolved))
@ -439,7 +443,7 @@
(force-output (current-output-port)) (force-output (current-output-port))
(force-output (current-error-port)) (force-output (current-error-port))
(if server-listening? (if server-listening?
(let ((pid (primitive-fork))) (let ((pid (primitive-fork-if-available)))
;; Spawn a server process. ;; Spawn a server process.
(case pid (case pid
((-1) (throw 'unresolved)) ((-1) (throw 'unresolved))

4
test-suite/tests/ports.test
View file

@ -2,7 +2,7 @@
;;;; Jim Blandy <jimb@red-bean.com> --- May 1999 ;;;; Jim Blandy <jimb@red-bean.com> --- May 1999
;;;; ;;;;
;;;; Copyright (C) 1999, 2001, 2004, 2006, 2007, 2009, 2010, ;;;; Copyright (C) 1999, 2001, 2004, 2006, 2007, 2009, 2010,
;;;; 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc. ;;;; 2011, 2012, 2013, 2014, 2015, 2017 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -638,6 +638,8 @@
(pass-if-equal "pipe, fdopen, and line buffering" (pass-if-equal "pipe, fdopen, and line buffering"
"foo\nbar\n" "foo\nbar\n"
(unless (provided? 'fork)
(throw 'unresolved))
(let ((in+out (pipe)) (let ((in+out (pipe))
(pid (primitive-fork))) (pid (primitive-fork)))
(if (zero? pid) (if (zero? pid)