summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorKevin Ryde <user42@zip.com.au>2006-07-23 22:23:58 +0000
committerKevin Ryde <user42@zip.com.au>2006-07-23 22:23:58 +0000
commit80f1ae33106344f39cc58d2406e404322b6473e5 (patch)
tree974a50e79f3c184c8d6f84dbc799f32adba05f48
parent0af390c7294ff49fdb930ea2bd0caf4b17ab85db (diff)
downloadguile-80f1ae33106344f39cc58d2406e404322b6473e5.tar.gz
New file, exercising htonl and ntohl.
-rw-r--r--test-suite/tests/socket.test294
1 files changed, 60 insertions, 234 deletions
diff --git a/test-suite/tests/socket.test b/test-suite/tests/socket.test
index dd91f35b6..8768e635b 100644
--- a/test-suite/tests/socket.test
+++ b/test-suite/tests/socket.test
@@ -1,255 +1,81 @@
-;;;; socket.test --- test socket functions -*- scheme -*-
+;;;; numbers.test --- tests guile's numbers -*- scheme -*-
+;;;; Copyright (C) 2000, 2001, 2004, 2005 Free Software Foundation, Inc.
;;;;
-;;;; Copyright (C) 2004, 2005, 2006 Free Software Foundation, Inc.
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
;;;;
-;;;; 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,
+;;;; This program 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-numbers)
- #:use-module (test-suite lib))
-
-
-;;;
-;;; 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))
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+;;;;
+;;;; As a special exception, the Free Software Foundation gives permission
+;;;; for additional uses of the text contained in its release of GUILE.
+;;;;
+;;;; The exception is that, if you link the GUILE library with other files
+;;;; to produce an executable, this does not by itself cause the
+;;;; resulting executable to be covered by the GNU General Public License.
+;;;; Your use of that executable is in no way restricted on account of
+;;;; linking the GUILE library code into it.
+;;;;
+;;;; This exception does not however invalidate any other reasons why
+;;;; the executable file might be covered by the GNU General Public License.
+;;;;
+;;;; This exception applies only to the code released by the
+;;;; Free Software Foundation under the name GUILE. If you copy
+;;;; code from other Free Software Foundation releases into a copy of
+;;;; GUILE, as the General Public License permits, the exception does
+;;;; not apply to the code that you add in this way. To avoid misleading
+;;;; anyone as to the status of such modified files, you must delete
+;;;; this exception notice from them.
+;;;;
+;;;; If you write modifications of your own for GUILE, it is your choice
+;;;; whether to permit this exception to apply to your modifications.
+;;;; If you do not wish that, delete this exception notice.
- (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
+;;; htonl
;;;
-(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")))
+(with-test-prefix "htonl"
- (pass-if "::1"
- (eqv? 1 (inet-pton AF_INET6 "::1")))
+ (pass-if "0" (eqv? 0 (htonl 0)))
- (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-exception "-1" exception:out-of-range
+ (htonl -1))
- (pass-if "F000:0000:0000:0000:0000:0000:0000:0000"
- (eqv? #xF0000000000000000000000000000000
- (inet-pton AF_INET6
- "F000:0000:0000:0000:0000:0000:0000:0000")))
+ ;; 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 "0F00:0000:0000:0000:0000:0000:0000:0000"
- (eqv? #x0F000000000000000000000000000000
- (inet-pton AF_INET6
- "0F00:0000:0000:0000:0000:0000:0000:0000")))
+ (pass-if-exception "2^1024" exception:out-of-range
+ (htonl (ash 1 1024))))
- (pass-if "0000:0000:0000:0000:0000:0000:0000:00F0"
- (eqv? #xF0
- (inet-pton AF_INET6
- "0000:0000:0000:0000:0000:0000:0000:00F0"))))))
-
-
;;;
-;;; make-socket-address
+;;; ntohl
;;;
-(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"))))))
-
-
-
-;;;
-;;; AF_UNIX sockets and `make-socket-address'
-;;;
-
-(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 (tmpnam)))
-
- (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 (tmpnam))
- (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 (tmpnam)))
-
- (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 (tmpnam))
- (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)))
+(with-test-prefix "ntohl"
- (pass-if "accept"
- (if (not server-pid)
- (throw 'unresolved)
- (let ((status (cdr (waitpid server-pid))))
- (eq? 0 (status:exit-val status)))))
+ (pass-if "0" (eqv? 0 (ntohl 0)))
- (false-if-exception (delete-file path))
+ (pass-if-exception "-1" exception:out-of-range
+ (ntohl -1))
- #t)))
+ ;; 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))))