warn on multithreaded fork

* libguile/posix.c (scm_fork): Issue a warning on a multithreaded fork.
* doc/ref/posix.texi (Processes): Add note about multithreaded fork.

* test-suite/tests/00-socket.test: Moved here, from socket.test, so as
  to run before any threads are created.
* test-suite/Makefile.am: Adapt.

1 files changed, 513 insertions, 0 deletions

diff --git a/test-suite/tests/00-socket.test b/test-suite/tests/00-socket.test
new file mode 100644
index 000000000..6deb28542
--- /dev/null
+++ b/test-suite/tests/00-socket.test
@@ -0,0 +1,513 @@
+;;;; socket.test --- test socket functions     -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 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
+
+(define-module (test-suite test-socket)
+  #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-26)
+  #:use-module (test-suite lib))
+
+
+
+;;;
+;;; htonl
+;;;
+
+(if (defined? 'htonl)
+    (with-test-prefix "htonl"
+
+      (pass-if "0" (eqv? 0 (htonl 0)))
+
+      (pass-if-exception "-1" exception:out-of-range
+        (htonl -1))
+
+      ;; prior to guile 1.6.9 and 1.8.1, systems with 64-bit longs didn't detect
+      ;; an overflow for values 2^32 <= x < 2^63
+      (pass-if-exception "2^32" exception:out-of-range
+        (htonl (ash 1 32)))
+
+      (pass-if-exception "2^1024" exception:out-of-range
+        (htonl (ash 1 1024)))))
+
+
+;;;
+;;; inet-ntop
+;;;
+
+(if (defined? 'inet-ntop)
+    (with-test-prefix "inet-ntop"
+
+      (with-test-prefix "ipv6"
+	(pass-if "0"
+	  (string? (inet-ntop AF_INET6 0)))
+
+	(pass-if "2^128-1"
+	  (string? (inet-ntop AF_INET6 (1- (ash 1 128)))))
+
+	(pass-if-exception "-1" exception:out-of-range
+	  (inet-ntop AF_INET6 -1))
+
+	(pass-if-exception "2^128" exception:out-of-range
+	  (inet-ntop AF_INET6 (ash 1 128)))
+
+	(pass-if-exception "2^1024" exception:out-of-range
+	  (inet-ntop AF_INET6 (ash 1 1024))))))
+
+;;;
+;;; inet-pton
+;;;
+
+(if (defined? 'inet-pton)
+    (with-test-prefix "inet-pton"
+
+      (with-test-prefix "ipv6"
+	(pass-if "00:00:00:00:00:00:00:00"
+	  (eqv? 0 (inet-pton AF_INET6 "00:00:00:00:00:00:00:00")))
+
+	(pass-if "0:0:0:0:0:0:0:1"
+	  (eqv? 1 (inet-pton AF_INET6 "0:0:0:0:0:0:0:1")))
+
+	(pass-if "::1"
+	  (eqv? 1 (inet-pton AF_INET6 "::1")))
+
+	(pass-if "FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF"
+	  (eqv? #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
+		(inet-pton AF_INET6
+			   "FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF")))
+
+	(pass-if "F000:0000:0000:0000:0000:0000:0000:0000"
+	  (eqv? #xF0000000000000000000000000000000
+		(inet-pton AF_INET6
+			   "F000:0000:0000:0000:0000:0000:0000:0000")))
+
+	(pass-if "0F00:0000:0000:0000:0000:0000:0000:0000"
+	  (eqv? #x0F000000000000000000000000000000
+		(inet-pton AF_INET6
+			   "0F00:0000:0000:0000:0000:0000:0000:0000")))
+
+	(pass-if "0000:0000:0000:0000:0000:0000:0000:00F0"
+	  (eqv? #xF0
+		(inet-pton AF_INET6
+			   "0000:0000:0000:0000:0000:0000:0000:00F0"))))))
+
+(if (defined? 'inet-ntop)
+    (with-test-prefix "inet-ntop"
+
+      (with-test-prefix "ipv4"
+	(pass-if "127.0.0.1"
+	  (equal? "127.0.0.1" (inet-ntop AF_INET INADDR_LOOPBACK))))
+
+      (if (defined? 'AF_INET6)
+	  (with-test-prefix "ipv6"
+	    (pass-if "FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF"
+	      (string-ci=? "FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF"
+			   (inet-ntop AF_INET6 (- (expt 2 128) 1))))
+
+	    (pass-if "::1"
+	      (equal? "::1" (inet-ntop AF_INET6 1)))))))
+
+
+;;;
+;;; make-socket-address
+;;;
+
+(with-test-prefix "make-socket-address"
+  (if (defined? 'AF_INET)
+      (pass-if "AF_INET"
+	(let ((sa (make-socket-address AF_INET 123456 80)))
+	  (and (= (sockaddr:fam  sa) AF_INET)
+	       (= (sockaddr:addr sa) 123456)
+	       (= (sockaddr:port sa) 80)))))
+
+  (if (defined? 'AF_INET6)
+      (pass-if "AF_INET6"
+	;; Since the platform doesn't necessarily support `scopeid', we won't
+        ;; test it.
+	(let ((sa* (make-socket-address AF_INET6 123456 80 1))
+	      (sa+ (make-socket-address AF_INET6 123456 80)))
+	  (and (= (sockaddr:fam  sa*) (sockaddr:fam  sa+) AF_INET6)
+	       (= (sockaddr:addr sa*) (sockaddr:addr sa+) 123456)
+	       (= (sockaddr:port sa*) (sockaddr:port sa+) 80)
+	       (= (sockaddr:flowinfo sa*) 1)))))
+
+  (if (defined? 'AF_UNIX)
+      (pass-if "AF_UNIX"
+	(let ((sa (make-socket-address AF_UNIX "/tmp/unix-socket")))
+	  (and (= (sockaddr:fam sa) AF_UNIX)
+	       (string=? (sockaddr:path sa) "/tmp/unix-socket"))))))
+
+;;;
+;;; ntohl
+;;;
+
+(if (defined? 'ntohl)
+    (with-test-prefix "ntohl"
+
+      (pass-if "0" (eqv? 0 (ntohl 0)))
+
+      (pass-if-exception "-1" exception:out-of-range
+        (ntohl -1))
+
+      ;; prior to guile 1.6.9 and 1.8.1, systems with 64-bit longs didn't detect
+      ;; an overflow for values 2^32 <= x < 2^63
+      (pass-if-exception "2^32" exception:out-of-range
+        (ntohl (ash 1 32)))
+
+      (pass-if-exception "2^1024" exception:out-of-range
+        (ntohl (ash 1 1024)))))
+
+
+
+;;;
+;;; AF_UNIX sockets and `make-socket-address'
+;;;
+
+(define %tmpdir
+  ;; Honor `$TMPDIR', which tmpnam(3) doesn't do.
+  (or (getenv "TMPDIR") "/tmp"))
+
+(define %curdir
+  ;; Remember the current working directory.
+  (getcwd))
+
+;; Temporarily cd to %TMPDIR.  The goal is to work around path name
+;; limitations, which can lead to exceptions like:
+;;
+;;  (misc-error "scm_to_sockaddr"
+;;              "unix address path too long: ~A"
+;;              ("/tmp/nix-build-fb7bph4ifh0vr3ihigm702dzffdnapfj-guile-coverage-1.9.5.drv-0/guile-test-socket-1258553296-77619")
+;;              #f)
+(chdir %tmpdir)
+
+(define (temp-file-path)
+  ;; Return a temporary file name, assuming the current directory is %TMPDIR.
+  (string-append "guile-test-socket-"
+                 (number->string (current-time)) "-"
+                 (number->string (random 100000))))
+
+
+(if (defined? 'AF_UNIX)
+    (with-test-prefix "AF_UNIX/SOCK_DGRAM"
+
+      ;; testing `bind' and `sendto' and datagram sockets
+
+      (let ((server-socket (socket AF_UNIX SOCK_DGRAM 0))
+	    (server-bound? #f)
+	    (path (temp-file-path)))
+
+	(pass-if "bind"
+	  (catch 'system-error
+	    (lambda ()
+	      (bind server-socket AF_UNIX path)
+	      (set! server-bound? #t)
+	      #t)
+	    (lambda args
+	      (let ((errno (system-error-errno args)))
+		(cond ((= errno EADDRINUSE) (throw 'unresolved))
+		      (else (apply throw args)))))))
+
+	(pass-if "bind/sockaddr"
+	  (let* ((sock (socket AF_UNIX SOCK_STREAM 0))
+		 (path (temp-file-path))
+		 (sockaddr (make-socket-address AF_UNIX path)))
+	    (catch 'system-error
+	      (lambda ()
+		(bind sock sockaddr)
+		(false-if-exception (delete-file path))
+		#t)
+	      (lambda args
+		(let ((errno (system-error-errno args)))
+		  (cond ((= errno EADDRINUSE) (throw 'unresolved))
+			(else (apply throw args))))))))
+
+	(pass-if "sendto"
+	  (if (not server-bound?)
+	      (throw 'unresolved)
+	      (let ((client  (socket AF_UNIX SOCK_DGRAM 0))
+                    (message (string->utf8 "hello")))
+		(> (sendto client message AF_UNIX path) 0))))
+
+	(pass-if "sendto/sockaddr"
+	  (if (not server-bound?)
+	      (throw 'unresolved)
+	      (let ((client   (socket AF_UNIX SOCK_DGRAM 0))
+                    (message  (string->utf8 "hello"))
+		    (sockaddr (make-socket-address AF_UNIX path)))
+		(> (sendto client message sockaddr) 0))))
+
+	(false-if-exception (delete-file path)))))
+
+
+(if (defined? 'AF_UNIX)
+    (with-test-prefix "AF_UNIX/SOCK_STREAM"
+
+      ;; testing `bind', `listen' and `connect' on stream-oriented sockets
+
+      (let ((server-socket (socket AF_UNIX SOCK_STREAM 0))
+	    (server-bound? #f)
+	    (server-listening? #f)
+	    (server-pid #f)
+	    (path (temp-file-path)))
+
+	(pass-if "bind"
+	  (catch 'system-error
+	    (lambda ()
+	      (bind server-socket AF_UNIX path)
+	      (set! server-bound? #t)
+	      #t)
+	    (lambda args
+	      (let ((errno (system-error-errno args)))
+		(cond ((= errno EADDRINUSE) (throw 'unresolved))
+		      (else (apply throw args)))))))
+
+	(pass-if "bind/sockaddr"
+	  (let* ((sock (socket AF_UNIX SOCK_STREAM 0))
+		 (path (temp-file-path))
+		 (sockaddr (make-socket-address AF_UNIX path)))
+	    (catch 'system-error
+	      (lambda ()
+		(bind sock sockaddr)
+		(false-if-exception (delete-file path))
+		#t)
+	      (lambda args
+		(let ((errno (system-error-errno args)))
+		  (cond ((= errno EADDRINUSE) (throw 'unresolved))
+			(else (apply throw args))))))))
+
+	(pass-if "listen"
+	  (if (not server-bound?)
+	      (throw 'unresolved)
+	      (begin
+		(listen server-socket 123)
+		(set! server-listening? #t)
+		#t)))
+
+	(force-output (current-output-port))
+	(force-output (current-error-port))
+	(if server-listening?
+	    (let ((pid (primitive-fork)))
+	      ;; Spawn a server process.
+	      (case pid
+		((-1) (throw 'unresolved))
+		((0)   ;; the kid:  serve two connections and exit
+		 (let serve ((conn
+			      (false-if-exception (accept server-socket)))
+			     (count 1))
+		   (if (not conn)
+		       (exit 1)
+		       (if (> count 0)
+			   (serve (false-if-exception (accept server-socket))
+				  (- count 1)))))
+		 (exit 0))
+		(else  ;; the parent
+		 (set! server-pid pid)
+		 #t))))
+
+	(pass-if "connect"
+	  (if (not server-pid)
+	      (throw 'unresolved)
+	      (let ((s (socket AF_UNIX SOCK_STREAM 0)))
+		(connect s AF_UNIX path)
+		#t)))
+
+	(pass-if "connect/sockaddr"
+	  (if (not server-pid)
+	      (throw 'unresolved)
+	      (let ((s (socket AF_UNIX SOCK_STREAM 0)))
+		(connect s (make-socket-address AF_UNIX path))
+		#t)))
+
+	(pass-if "accept"
+	  (if (not server-pid)
+	      (throw 'unresolved)
+	      (let ((status (cdr (waitpid server-pid))))
+		(eq? 0 (status:exit-val status)))))
+
+	(false-if-exception (delete-file path))
+
+	#t)
+
+
+      ;; Testing `send', `recv!' & co. on stream-oriented sockets (with
+      ;; a bit of duplication with the above.)
+
+      (let ((server-socket     (socket AF_UNIX SOCK_STREAM 0))
+            (server-bound?     #f)
+            (server-listening? #f)
+            (server-pid        #f)
+            (message           "hello, world!")
+            (path              (temp-file-path)))
+
+        (define (sub-bytevector bv len)
+          (let ((c (make-bytevector len)))
+            (bytevector-copy! bv 0 c 0 len)
+            c))
+
+        (pass-if "bind (bis)"
+          (catch 'system-error
+            (lambda ()
+              (bind server-socket AF_UNIX path)
+              (set! server-bound? #t)
+              #t)
+            (lambda args
+              (let ((errno (system-error-errno args)))
+                (cond ((= errno EADDRINUSE) (throw 'unresolved))
+                      (else (apply throw args)))))))
+
+        (pass-if "listen (bis)"
+          (if (not server-bound?)
+              (throw 'unresolved)
+              (begin
+                (listen server-socket 123)
+                (set! server-listening? #t)
+                #t)))
+
+        (force-output (current-output-port))
+        (force-output (current-error-port))
+        (if server-listening?
+            (let ((pid (primitive-fork)))
+              ;; Spawn a server process.
+              (case pid
+                ((-1) (throw 'unresolved))
+                ((0)   ;; the kid: send MESSAGE and exit
+                 (exit
+                  (false-if-exception
+                   (let ((conn (car (accept server-socket)))
+                         (bv   (string->utf8 message)))
+                     (= (bytevector-length bv)
+                        (send conn bv))))))
+                (else  ;; the parent
+                 (set! server-pid pid)
+                 #t))))
+
+        (pass-if "recv!"
+          (if (not server-pid)
+              (throw 'unresolved)
+              (let ((s (socket AF_UNIX SOCK_STREAM 0)))
+                (connect s AF_UNIX path)
+                (let* ((buf      (make-bytevector 123))
+                       (received (recv! s buf)))
+                  (string=? (utf8->string (sub-bytevector buf received))
+                            message)))))
+
+        (pass-if "accept (bis)"
+          (if (not server-pid)
+              (throw 'unresolved)
+              (let ((status (cdr (waitpid server-pid))))
+                (eq? 0 (status:exit-val status)))))
+
+        (false-if-exception (delete-file path))
+
+        #t)))
+
+
+(if (defined? 'AF_INET6)
+    (with-test-prefix "AF_INET6/SOCK_STREAM"
+
+      ;; testing `bind', `listen' and `connect' on stream-oriented sockets
+
+      (let ((server-socket
+             ;; Some platforms don't support this protocol/family combination.
+             (false-if-exception (socket AF_INET6 SOCK_STREAM 0)))
+	    (server-bound? #f)
+	    (server-listening? #f)
+	    (server-pid #f)
+	    (ipv6-addr 1)		; ::1
+	    (server-port 8889)
+	    (client-port 9998))
+
+	(pass-if "bind"
+          (if (not server-socket)
+              (throw 'unresolved))
+	  (catch 'system-error
+	    (lambda ()
+	      (bind server-socket AF_INET6 ipv6-addr server-port)
+	      (set! server-bound? #t)
+	      #t)
+	    (lambda args
+	      (let ((errno (system-error-errno args)))
+		(cond ((= errno EADDRINUSE) (throw 'unresolved))
+		      (else (apply throw args)))))))
+
+	(pass-if "bind/sockaddr"
+	  (let* ((sock (false-if-exception (socket AF_INET6 SOCK_STREAM 0)))
+		 (sockaddr (make-socket-address AF_INET6 ipv6-addr client-port)))
+            (if (not sock)
+                (throw 'unresolved))
+	    (catch 'system-error
+	      (lambda ()
+		(bind sock sockaddr)
+		#t)
+	      (lambda args
+		(let ((errno (system-error-errno args)))
+		  (cond ((= errno EADDRINUSE) (throw 'unresolved))
+			(else (apply throw args))))))))
+
+	(pass-if "listen"
+	  (if (not server-bound?)
+	      (throw 'unresolved)
+	      (begin
+		(listen server-socket 123)
+		(set! server-listening? #t)
+		#t)))
+
+	(force-output (current-output-port))
+	(force-output (current-error-port))
+	(if server-listening?
+	    (let ((pid (primitive-fork)))
+	      ;; Spawn a server process.
+	      (case pid
+		((-1) (throw 'unresolved))
+		((0)   ;; the kid:  serve two connections and exit
+		 (let serve ((conn
+			      (false-if-exception (accept server-socket)))
+			     (count 1))
+		   (if (not conn)
+		       (exit 1)
+		       (if (> count 0)
+			   (serve (false-if-exception (accept server-socket))
+				  (- count 1)))))
+		 (exit 0))
+		(else  ;; the parent
+		 (set! server-pid pid)
+		 #t))))
+
+	(pass-if "connect"
+	  (if (not server-pid)
+	      (throw 'unresolved)
+	      (let ((s (socket AF_INET6 SOCK_STREAM 0)))
+		(connect s AF_INET6 ipv6-addr server-port)
+		#t)))
+
+	(pass-if "connect/sockaddr"
+	  (if (not server-pid)
+	      (throw 'unresolved)
+	      (let ((s (socket AF_INET6 SOCK_STREAM 0)))
+		(connect s (make-socket-address AF_INET6 ipv6-addr server-port))
+		#t)))
+
+	(pass-if "accept"
+	  (if (not server-pid)
+	      (throw 'unresolved)
+	      (let ((status (cdr (waitpid server-pid))))
+		(eq? 0 (status:exit-val status)))))
+
+	#t)))
+
+;; Switch back to the previous directory.
+(false-if-exception (chdir %curdir))