From 80f1ae33106344f39cc58d2406e404322b6473e5 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sun, 23 Jul 2006 22:23:58 +0000 Subject: [PATCH] New file, exercising htonl and ntohl. --- test-suite/tests/socket.test | 294 +++++++---------------------------- 1 file 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 +;;;; 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. -(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)) - - (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 "htonl" - (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" (eqv? 0 (htonl 0))) - (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-exception "-1" exception:out-of-range + (htonl -1)) - (pass-if "::1" - (eqv? 1 (inet-pton AF_INET6 "::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 "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 "2^1024" exception:out-of-range + (htonl (ash 1 1024)))) - (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")))))) - - ;;; -;;; 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))))) +(with-test-prefix "ntohl" - (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))))) + (pass-if "0" (eqv? 0 (ntohl 0))) - (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")))))) + (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))) - -;;; -;;; 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))) - - (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))) - + (pass-if-exception "2^1024" exception:out-of-range + (ntohl (ash 1 1024))))