Fix bug #31081 (`lookahead-u8' returns an s8.)

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

diff --git a/test-suite/tests/socket.test b/test-suite/tests/socket.test
index 4bfc415..7389cee 100644 (file)
--- a/test-suite/tests/socket.test
+++ b/test-suite/tests/socket.test
@@ -1,11 +1,11 @@
 ;;;; socket.test --- test socket functions     -*- scheme -*-
 ;;;;
-;;;; Copyright (C) 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+;;;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 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.
+;;;; 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
@@ -174,13 +174,28 @@
 ;;; 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 path that honors `$TMPDIR', which `tmpnam'
-  ;; doesn't do.
-  (let ((dir (or (getenv "TMPDIR") "/tmp")))
-    (string-append dir "/guile-test-socket-"
-                   (number->string (current-time)) "-"
-                   (number->string (random 100000)))))
+  ;; 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)
@@ -277,6 +292,8 @@
                (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.
@@ -320,3 +337,99 @@
 
        #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))