[bpt/guile.git] / test-suite / tests / 00-socket.test

;;;; socket.test --- test socket functions     -*- scheme -*-
;;;;
;;;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010,
;;;;   2011, 2013, 2014 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))

\f

;;;
;;; 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)))))))

\f
;;;
;;; 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"))))))

\f
;;;
;;; 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))))
		(eqv? 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))))
                (eqv? 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))

                      ;; On Linux-based systems, when `ipv6' support is
                      ;; missing (for instance, `ipv6' is loaded and
                      ;; /proc/sys/net/ipv6/conf/all/disable_ipv6 is set
                      ;; to 1), the socket call above succeeds but
                      ;; bind(2) fails like this.
                      ((= errno EADDRNOTAVAIL) (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))
                        ((= errno EADDRNOTAVAIL) (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))))
		(eqv? 0 (status:exit-val status)))))

	#t)))

;; Switch back to the previous directory.
(false-if-exception (chdir %curdir))
Commit	Line	Data
4064ed2a KR	1	;;;; socket.test --- test socket functions -- scheme --
4064ed2a KR	2	;;;;
d21a1dc8	3	;;;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010,
b9b88351	4	;;;; 2011, 2013, 2014 Free Software Foundation, Inc.
4064ed2a KR	5	;;;;
	6	;;;; This library is free software; you can redistribute it and/or
	7	;;;; modify it under the terms of the GNU Lesser General Public
	8	;;;; License as published by the Free Software Foundation; either
53befeb7	9	;;;; version 3 of the License, or (at your option) any later version.
d21a1dc8	10	;;;;
4064ed2a KR	11	;;;; This library is distributed in the hope that it will be useful,
	12	;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	13	;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	14	;;;; Lesser General Public License for more details.
d21a1dc8	15	;;;;
4064ed2a KR	16	;;;; You should have received a copy of the GNU Lesser General Public
4064ed2a KR	17	;;;; License along with this library; if not, write to the Free Software
92205699	18	;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
4064ed2a	19
7a5fb796	20	(define-module (test-suite test-socket)
d21a1dc8	21	#:use-module (rnrs bytevectors)
9d46abb0	22	#:use-module (srfi srfi-26)
4064ed2a KR	23	#:use-module (test-suite lib))
4064ed2a KR	24
e7e48080	25	\f
8ab3d8a0	26
4064ed2a KR	27	;;;
	28	;;; inet-ntop
	29	;;;
	30
	31	(if (defined? 'inet-ntop)
	32	(with-test-prefix "inet-ntop"
	33
	34	(with-test-prefix "ipv6"
	35	(pass-if "0"
	36	(string? (inet-ntop AF_INET6 0)))
	37
	38	(pass-if "2^128-1"
	39	(string? (inet-ntop AF_INET6 (1- (ash 1 128)))))
	40
	41	(pass-if-exception "-1" exception:out-of-range
	42	(inet-ntop AF_INET6 -1))
	43
	44	(pass-if-exception "2^128" exception:out-of-range
	45	(inet-ntop AF_INET6 (ash 1 128)))
	46
	47	(pass-if-exception "2^1024" exception:out-of-range
	48	(inet-ntop AF_INET6 (ash 1 1024))))))
3810edd9 KR	49
	50	;;;
	51	;;; inet-pton
	52	;;;
	53
	54	(if (defined? 'inet-pton)
	55	(with-test-prefix "inet-pton"
	56
	57	(with-test-prefix "ipv6"
	58	(pass-if "00:00:00:00:00:00:00:00"
	59	(eqv? 0 (inet-pton AF_INET6 "00:00:00:00:00:00:00:00")))
	60
	61	(pass-if "0:0:0:0:0:0:0:1"
	62	(eqv? 1 (inet-pton AF_INET6 "0:0:0:0:0:0:0:1")))
	63
	64	(pass-if "::1"
	65	(eqv? 1 (inet-pton AF_INET6 "::1")))
	66
	67	(pass-if "FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF"
	68	(eqv? #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
	69	(inet-pton AF_INET6
	70	"FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF")))
	71
	72	(pass-if "F000:0000:0000:0000:0000:0000:0000:0000"
	73	(eqv? #xF0000000000000000000000000000000
	74	(inet-pton AF_INET6
	75	"F000:0000:0000:0000:0000:0000:0000:0000")))
	76
	77	(pass-if "0F00:0000:0000:0000:0000:0000:0000:0000"
	78	(eqv? #x0F000000000000000000000000000000
	79	(inet-pton AF_INET6
	80	"0F00:0000:0000:0000:0000:0000:0000:0000")))
	81
	82	(pass-if "0000:0000:0000:0000:0000:0000:0000:00F0"
	83	(eqv? #xF0
	84	(inet-pton AF_INET6
	85	"0000:0000:0000:0000:0000:0000:0000:00F0"))))))
e7e48080	86
7a5fb796 LC	87	(if (defined? 'inet-ntop)
	88	(with-test-prefix "inet-ntop"
	89
	90	(with-test-prefix "ipv4"
	91	(pass-if "127.0.0.1"
	92	(equal? "127.0.0.1" (inet-ntop AF_INET INADDR_LOOPBACK))))
	93
	94	(if (defined? 'AF_INET6)
	95	(with-test-prefix "ipv6"
	96	(pass-if "FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF"
	97	(string-ci=? "FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF"
	98	(inet-ntop AF_INET6 (- (expt 2 128) 1))))
	99
	100	(pass-if "::1"
	101	(equal? "::1" (inet-ntop AF_INET6 1)))))))
	102
e7e48080 KR	103	\f
	104	;;;
	105	;;; make-socket-address
	106	;;;
	107
	108	(with-test-prefix "make-socket-address"
	109	(if (defined? 'AF_INET)
	110	(pass-if "AF_INET"
	111	(let ((sa (make-socket-address AF_INET 123456 80)))
	112	(and (= (sockaddr:fam sa) AF_INET)
	113	(= (sockaddr:addr sa) 123456)
	114	(= (sockaddr:port sa) 80)))))
	115
	116	(if (defined? 'AF_INET6)
	117	(pass-if "AF_INET6"
	118	;; Since the platform doesn't necessarily support `scopeid', we won't
	119	;; test it.
	120	(let ((sa* (make-socket-address AF_INET6 123456 80 1))
	121	(sa+ (make-socket-address AF_INET6 123456 80)))
	122	(and (= (sockaddr:fam sa*) (sockaddr:fam sa+) AF_INET6)
	123	(= (sockaddr:addr sa*) (sockaddr:addr sa+) 123456)
	124	(= (sockaddr:port sa*) (sockaddr:port sa+) 80)
	125	(= (sockaddr:flowinfo sa*) 1)))))
	126
	127	(if (defined? 'AF_UNIX)
	128	(pass-if "AF_UNIX"
	129	(let ((sa (make-socket-address AF_UNIX "/tmp/unix-socket")))
	130	(and (= (sockaddr:fam sa) AF_UNIX)
	131	(string=? (sockaddr:path sa) "/tmp/unix-socket"))))))
	132
e7e48080 KR	133	\f
	134	;;;
	135	;;; AF_UNIX sockets and `make-socket-address'
	136	;;;
	137
91cbeffc LC	138	(define %tmpdir
	139	;; Honor `$TMPDIR', which tmpnam(3) doesn't do.
	140	(or (getenv "TMPDIR") "/tmp"))
	141
	142	(define %curdir
	143	;; Remember the current working directory.
	144	(getcwd))
	145
	146	;; Temporarily cd to %TMPDIR. The goal is to work around path name
	147	;; limitations, which can lead to exceptions like:
	148	;;
	149	;; (misc-error "scm_to_sockaddr"
	150	;; "unix address path too long: ~A"
	151	;; ("/tmp/nix-build-fb7bph4ifh0vr3ihigm702dzffdnapfj-guile-coverage-1.9.5.drv-0/guile-test-socket-1258553296-77619")
	152	;; #f)
	153	(chdir %tmpdir)
	154
eedcb08a	155	(define (temp-file-path)
91cbeffc LC	156	;; Return a temporary file name, assuming the current directory is %TMPDIR.
	157	(string-append "guile-test-socket-"
	158	(number->string (current-time)) "-"
	159	(number->string (random 100000))))
eedcb08a LC	160
eedcb08a LC	161
e7e48080 KR	162	(if (defined? 'AF_UNIX)
	163	(with-test-prefix "AF_UNIX/SOCK_DGRAM"
	164
	165	;; testing `bind' and `sendto' and datagram sockets
	166
	167	(let ((server-socket (socket AF_UNIX SOCK_DGRAM 0))
	168	(server-bound? #f)
eedcb08a	169	(path (temp-file-path)))
e7e48080 KR	170
	171	(pass-if "bind"
	172	(catch 'system-error
	173	(lambda ()
	174	(bind server-socket AF_UNIX path)
	175	(set! server-bound? #t)
	176	#t)
	177	(lambda args
	178	(let ((errno (system-error-errno args)))
	179	(cond ((= errno EADDRINUSE) (throw 'unresolved))
	180	(else (apply throw args)))))))
	181
	182	(pass-if "bind/sockaddr"
	183	(let* ((sock (socket AF_UNIX SOCK_STREAM 0))
eedcb08a	184	(path (temp-file-path))
e7e48080 KR	185	(sockaddr (make-socket-address AF_UNIX path)))
	186	(catch 'system-error
	187	(lambda ()
	188	(bind sock sockaddr)
	189	(false-if-exception (delete-file path))
	190	#t)
	191	(lambda args
	192	(let ((errno (system-error-errno args)))
	193	(cond ((= errno EADDRINUSE) (throw 'unresolved))
	194	(else (apply throw args))))))))
	195
	196	(pass-if "sendto"
	197	(if (not server-bound?)
	198	(throw 'unresolved)
d21a1dc8 LC	199	(let ((client (socket AF_UNIX SOCK_DGRAM 0))
	200	(message (string->utf8 "hello")))
	201	(> (sendto client message AF_UNIX path) 0))))
e7e48080 KR	202
	203	(pass-if "sendto/sockaddr"
	204	(if (not server-bound?)
	205	(throw 'unresolved)
d21a1dc8 LC	206	(let ((client (socket AF_UNIX SOCK_DGRAM 0))
d21a1dc8 LC	207	(message (string->utf8 "hello"))
e7e48080	208	(sockaddr (make-socket-address AF_UNIX path)))
d21a1dc8	209	(> (sendto client message sockaddr) 0))))
e7e48080 KR	210
	211	(false-if-exception (delete-file path)))))
	212
	213
	214	(if (defined? 'AF_UNIX)
	215	(with-test-prefix "AF_UNIX/SOCK_STREAM"
	216
	217	;; testing `bind', `listen' and `connect' on stream-oriented sockets
	218
	219	(let ((server-socket (socket AF_UNIX SOCK_STREAM 0))
	220	(server-bound? #f)
	221	(server-listening? #f)
	222	(server-pid #f)
eedcb08a	223	(path (temp-file-path)))
e7e48080 KR	224
	225	(pass-if "bind"
	226	(catch 'system-error
	227	(lambda ()
	228	(bind server-socket AF_UNIX path)
	229	(set! server-bound? #t)
	230	#t)
	231	(lambda args
	232	(let ((errno (system-error-errno args)))
	233	(cond ((= errno EADDRINUSE) (throw 'unresolved))
	234	(else (apply throw args)))))))
	235
	236	(pass-if "bind/sockaddr"
	237	(let* ((sock (socket AF_UNIX SOCK_STREAM 0))
eedcb08a	238	(path (temp-file-path))
e7e48080 KR	239	(sockaddr (make-socket-address AF_UNIX path)))
	240	(catch 'system-error
	241	(lambda ()
	242	(bind sock sockaddr)
	243	(false-if-exception (delete-file path))
	244	#t)
	245	(lambda args
	246	(let ((errno (system-error-errno args)))
	247	(cond ((= errno EADDRINUSE) (throw 'unresolved))
	248	(else (apply throw args))))))))
	249
	250	(pass-if "listen"
	251	(if (not server-bound?)
	252	(throw 'unresolved)
	253	(begin
	254	(listen server-socket 123)
	255	(set! server-listening? #t)
	256	#t)))
	257
5ebc8b81 KR	258	(force-output (current-output-port))
5ebc8b81 KR	259	(force-output (current-error-port))
e7e48080 KR	260	(if server-listening?
	261	(let ((pid (primitive-fork)))
	262	;; Spawn a server process.
	263	(case pid
	264	((-1) (throw 'unresolved))
	265	((0) ;; the kid: serve two connections and exit
	266	(let serve ((conn
	267	(false-if-exception (accept server-socket)))
	268	(count 1))
	269	(if (not conn)
	270	(exit 1)
	271	(if (> count 0)
	272	(serve (false-if-exception (accept server-socket))
	273	(- count 1)))))
	274	(exit 0))
	275	(else ;; the parent
	276	(set! server-pid pid)
	277	#t))))
	278
	279	(pass-if "connect"
	280	(if (not server-pid)
	281	(throw 'unresolved)
	282	(let ((s (socket AF_UNIX SOCK_STREAM 0)))
	283	(connect s AF_UNIX path)
	284	#t)))
	285
	286	(pass-if "connect/sockaddr"
	287	(if (not server-pid)
	288	(throw 'unresolved)
	289	(let ((s (socket AF_UNIX SOCK_STREAM 0)))
	290	(connect s (make-socket-address AF_UNIX path))
	291	#t)))
	292
	293	(pass-if "accept"
	294	(if (not server-pid)
	295	(throw 'unresolved)
	296	(let ((status (cdr (waitpid server-pid))))
764246cf	297	(eqv? 0 (status:exit-val status)))))
e7e48080 KR	298
	299	(false-if-exception (delete-file path))
	300
9d46abb0 LC	301	#t)
	302
	303
	304	;; Testing `send', `recv!' & co. on stream-oriented sockets (with
	305	;; a bit of duplication with the above.)
	306
	307	(let ((server-socket (socket AF_UNIX SOCK_STREAM 0))
	308	(server-bound? #f)
	309	(server-listening? #f)
	310	(server-pid #f)
	311	(message "hello, world!")
	312	(path (temp-file-path)))
	313
	314	(define (sub-bytevector bv len)
	315	(let ((c (make-bytevector len)))
	316	(bytevector-copy! bv 0 c 0 len)
	317	c))
	318
	319	(pass-if "bind (bis)"
	320	(catch 'system-error
	321	(lambda ()
	322	(bind server-socket AF_UNIX path)
	323	(set! server-bound? #t)
	324	#t)
	325	(lambda args
	326	(let ((errno (system-error-errno args)))
	327	(cond ((= errno EADDRINUSE) (throw 'unresolved))
	328	(else (apply throw args)))))))
	329
	330	(pass-if "listen (bis)"
	331	(if (not server-bound?)
	332	(throw 'unresolved)
	333	(begin
	334	(listen server-socket 123)
	335	(set! server-listening? #t)
	336	#t)))
	337
	338	(force-output (current-output-port))
	339	(force-output (current-error-port))
	340	(if server-listening?
	341	(let ((pid (primitive-fork)))
	342	;; Spawn a server process.
	343	(case pid
	344	((-1) (throw 'unresolved))
	345	((0) ;; the kid: send MESSAGE and exit
	346	(exit
	347	(false-if-exception
	348	(let ((conn (car (accept server-socket)))
	349	(bv (string->utf8 message)))
	350	(= (bytevector-length bv)
	351	(send conn bv))))))
	352	(else ;; the parent
	353	(set! server-pid pid)
	354	#t))))
	355
	356	(pass-if "recv!"
	357	(if (not server-pid)
	358	(throw 'unresolved)
	359	(let ((s (socket AF_UNIX SOCK_STREAM 0)))
	360	(connect s AF_UNIX path)
	361	(let* ((buf (make-bytevector 123))
	362	(received (recv! s buf)))
	363	(string=? (utf8->string (sub-bytevector buf received))
	364	message)))))
365
366	(pass-if "accept (bis)"
367	(if (not server-pid)
368	(throw 'unresolved)
369	(let ((status (cdr (waitpid server-pid))))
764246cf	370	(eqv? 0 (status:exit-val status)))))
9d46abb0 LC	371
	372	(false-if-exception (delete-file path))
	373
	374	#t)))
e7e48080	375
1ff4da65 NJ	376
	377	(if (defined? 'AF_INET6)
	378	(with-test-prefix "AF_INET6/SOCK_STREAM"
	379
	380	;; testing `bind', `listen' and `connect' on stream-oriented sockets
	381
d532c41b LC	382	(let ((server-socket
	383	;; Some platforms don't support this protocol/family combination.
	384	(false-if-exception (socket AF_INET6 SOCK_STREAM 0)))
1ff4da65 NJ	385	(server-bound? #f)
	386	(server-listening? #f)
	387	(server-pid #f)
	388	(ipv6-addr 1) ; ::1
	389	(server-port 8889)
	390	(client-port 9998))
	391
	392	(pass-if "bind"
d532c41b LC	393	(if (not server-socket)
d532c41b LC	394	(throw 'unresolved))
1ff4da65 NJ	395	(catch 'system-error
	396	(lambda ()
	397	(bind server-socket AF_INET6 ipv6-addr server-port)
	398	(set! server-bound? #t)
	399	#t)
	400	(lambda args
	401	(let ((errno (system-error-errno args)))
	402	(cond ((= errno EADDRINUSE) (throw 'unresolved))
3c8f2ae9 LC	403
	404	;; On Linux-based systems, when `ipv6' support is
	405	;; missing (for instance, `ipv6' is loaded and
	406	;; /proc/sys/net/ipv6/conf/all/disable_ipv6 is set
	407	;; to 1), the socket call above succeeds but
	408	;; bind(2) fails like this.
	409	((= errno EADDRNOTAVAIL) (throw 'unresolved))
	410
1ff4da65 NJ	411	(else (apply throw args)))))))
	412
	413	(pass-if "bind/sockaddr"
d532c41b	414	(let* ((sock (false-if-exception (socket AF_INET6 SOCK_STREAM 0)))
1ff4da65	415	(sockaddr (make-socket-address AF_INET6 ipv6-addr client-port)))
d532c41b LC	416	(if (not sock)
d532c41b LC	417	(throw 'unresolved))
1ff4da65 NJ	418	(catch 'system-error
	419	(lambda ()
	420	(bind sock sockaddr)
	421	#t)
	422	(lambda args
	423	(let ((errno (system-error-errno args)))
	424	(cond ((= errno EADDRINUSE) (throw 'unresolved))
3c8f2ae9	425	((= errno EADDRNOTAVAIL) (throw 'unresolved))
1ff4da65 NJ	426	(else (apply throw args))))))))
	427
	428	(pass-if "listen"
	429	(if (not server-bound?)
	430	(throw 'unresolved)
	431	(begin
	432	(listen server-socket 123)
	433	(set! server-listening? #t)
	434	#t)))
	435
5ebc8b81 KR	436	(force-output (current-output-port))
5ebc8b81 KR	437	(force-output (current-error-port))
1ff4da65 NJ	438	(if server-listening?
	439	(let ((pid (primitive-fork)))
	440	;; Spawn a server process.
	441	(case pid
	442	((-1) (throw 'unresolved))
	443	((0) ;; the kid: serve two connections and exit
	444	(let serve ((conn
	445	(false-if-exception (accept server-socket)))
	446	(count 1))
	447	(if (not conn)
	448	(exit 1)
	449	(if (> count 0)
	450	(serve (false-if-exception (accept server-socket))
	451	(- count 1)))))
	452	(exit 0))
	453	(else ;; the parent
	454	(set! server-pid pid)
	455	#t))))
	456
	457	(pass-if "connect"
	458	(if (not server-pid)
	459	(throw 'unresolved)
	460	(let ((s (socket AF_INET6 SOCK_STREAM 0)))
	461	(connect s AF_INET6 ipv6-addr server-port)
	462	#t)))
	463
	464	(pass-if "connect/sockaddr"
	465	(if (not server-pid)
	466	(throw 'unresolved)
	467	(let ((s (socket AF_INET6 SOCK_STREAM 0)))
	468	(connect s (make-socket-address AF_INET6 ipv6-addr server-port))
	469	#t)))
	470
	471	(pass-if "accept"
	472	(if (not server-pid)
	473	(throw 'unresolved)
	474	(let ((status (cdr (waitpid server-pid))))
764246cf	475	(eqv? 0 (status:exit-val status)))))
1ff4da65	476
91cbeffc LC	477	#t)))
	478
	479	;; Switch back to the previous directory.
	480	(false-if-exception (chdir %curdir))