--- /dev/null
+;;;; socket.test --- test socket functions -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009 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 2.1 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 (test-suite lib))
+
+\f
+
+;;;
+;;; 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)))))))
+
+\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"))))))
+
+;;;
+;;; 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)))))
+
+
+\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)))
+ (> (sendto client "hello" AF_UNIX path) 0))))
+
+ (pass-if "sendto/sockaddr"
+ (if (not server-bound?)
+ (throw 'unresolved)
+ (let ((client (socket AF_UNIX SOCK_DGRAM 0))
+ (sockaddr (make-socket-address AF_UNIX path)))
+ (> (sendto client "hello" 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)))
+
+ (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)))
+
+
+(if (defined? 'AF_INET6)
+ (with-test-prefix "AF_INET6/SOCK_STREAM"
+
+ ;; testing `bind', `listen' and `connect' on stream-oriented sockets
+
+ (let ((server-socket (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"
+ (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 (socket AF_INET6 SOCK_STREAM 0))
+ (sockaddr (make-socket-address AF_INET6 ipv6-addr client-port)))
+ (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)))
+
+ (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))
projects / lilypond.git / blobdiff