Added the support for bsd sockets made by Julian Stecklina and ported to windows by M. Goffioul

contrib/rt/rt.lisp

@@ -0,0 +1,254 @@
+#|----------------------------------------------------------------------------|
+ | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. |
+ |                                                                            |
+ | Permission  to  use,  copy, modify, and distribute this software  and  its |
+ | documentation for any purpose  and without fee is hereby granted, provided |
+ | that this copyright  and  permission  notice  appear  in  all  copies  and |
+ | supporting  documentation,  and  that  the  name  of M.I.T. not be used in |
+ | advertising or  publicity  pertaining  to  distribution  of  the  software |
+ | without   specific,   written   prior   permission.      M.I.T.  makes  no |
+ | representations  about  the  suitability of this software for any purpose. |
+ | It is provided "as is" without express or implied warranty.                |
+ |                                                                            |
+ |  M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE,  INCLUDING  |
+ |  ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL  |
+ |  M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL  DAMAGES  OR  |
+ |  ANY  DAMAGES  WHATSOEVER  RESULTING  FROM  LOSS OF USE, DATA OR PROFITS,  |
+ |  WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER  TORTIOUS  ACTION,  |
+ |  ARISING  OUT  OF  OR  IN  CONNECTION WITH THE USE OR PERFORMANCE OF THIS  |
+ |  SOFTWARE.                                                                 |
+ |----------------------------------------------------------------------------|#
+
+(defpackage :sb-rt
+  (:use #:cl)
+  (:export #:*do-tests-when-defined* #:*test* #:continue-testing
+	   #:deftest #:do-test #:do-tests #:get-test #:pending-tests
+	   #:rem-all-tests #:rem-test)
+  (:documentation "The MIT regression tester"))
+
+(in-package :sb-rt)
+
+(defvar *test* nil "Current test name")
+(defvar *do-tests-when-defined* nil)
+(defvar *entries* '(nil) "Test database")
+(defvar *in-test* nil "Used by TEST")
+(defvar *debug* nil "For debugging")
+(defvar *catch-errors* t
+  "When true, causes errors in a test to be caught.")
+(defvar *print-circle-on-failure* nil
+  "Failure reports are printed with *PRINT-CIRCLE* bound to this value.")
+(defvar *compile-tests* nil
+  "When true, compile the tests before running them.")
+(defvar *optimization-settings* '((safety 3)))
+(defvar *expected-failures* nil
+  "A list of test names that are expected to fail.")
+
+(defstruct (entry (:conc-name nil)
+		  (:type list))
+  pend name form)
+
+(defmacro vals (entry) `(cdddr ,entry))
+
+(defmacro defn (entry) `(cdr ,entry))
+
+(defun pending-tests ()
+  (do ((l (cdr *entries*) (cdr l))
+       (r nil))
+      ((null l) (nreverse r))
+    (when (pend (car l))
+      (push (name (car l)) r))))
+
+(defun rem-all-tests ()
+  (setq *entries* (list nil))
+  nil)
+
+(defun rem-test (&optional (name *test*))
+  (do ((l *entries* (cdr l)))
+      ((null (cdr l)) nil)
+    (when (equal (name (cadr l)) name)
+      (setf (cdr l) (cddr l))
+      (return name))))
+
+(defun get-test (&optional (name *test*))
+  (defn (get-entry name)))
+
+(defun get-entry (name)
+  (let ((entry (find name (cdr *entries*)
+		     :key #'name
+		     :test #'equal)))
+    (when (null entry)
+      (report-error t
+        "~%No test with name ~:@(~S~)."
+	name))
+    entry))
+
+(defmacro deftest (name form &rest values)
+  `(add-entry '(t ,name ,form .,values)))
+
+(defun add-entry (entry)
+  (setq entry (copy-list entry))
+  (do ((l *entries* (cdr l))) (nil)
+    (when (null (cdr l))
+      (setf (cdr l) (list entry))
+      (return nil))
+    (when (equal (name (cadr l)) 
+		 (name entry))
+      (setf (cadr l) entry)
+      (report-error nil
+        "Redefining test ~:@(~S~)"
+        (name entry))
+      (return nil)))
+  (when *do-tests-when-defined*
+    (do-entry entry))
+  (setq *test* (name entry)))
+
+(defun report-error (error? &rest args)
+  (cond (*debug* 
+	 (apply #'format t args)
+	 (if error? (throw '*debug* nil)))
+	(error? (apply #'error args))
+	(t (apply #'warn args))))
+
+(defun do-test (&optional (name *test*))
+  (do-entry (get-entry name)))
+
+(defun equalp-with-case (x y)
+  "Like EQUALP, but doesn't do case conversion of characters."
+  (cond
+   ((eq x y) t)
+   ((consp x)
+    (and (consp y)
+	 (equalp-with-case (car x) (car y))
+	 (equalp-with-case (cdr x) (cdr y))))
+   ((and (typep x 'array)
+	 (= (array-rank x) 0))
+    (equalp-with-case (aref x) (aref y)))
+   ((typep x 'vector)
+    (and (typep y 'vector)
+	 (let ((x-len (length x))
+	       (y-len (length y)))
+	   (and (eql x-len y-len)
+		(loop
+		 for e1 across x
+		 for e2 across y
+		 always (equalp-with-case e1 e2))))))
+   ((and (typep x 'array)
+	 (typep y 'array)
+	 (not (equal (array-dimensions x)
+		     (array-dimensions y))))
+    nil)
+   ((typep x 'array)
+    (and (typep y 'array)
+	 (let ((size (array-total-size x)))
+	   (loop for i from 0 below size
+		 always (equalp-with-case (row-major-aref x i)
+					  (row-major-aref y i))))))
+   (t (eql x y))))
+
+(defun do-entry (entry &optional
+		       (s *standard-output*))
+  (catch '*in-test*
+    (setq *test* (name entry))
+    (setf (pend entry) t)
+    (let* ((*in-test* t)
+	   ;; (*break-on-warnings* t)
+	   (aborted nil)
+	   r)
+      ;; (declare (special *break-on-warnings*))
+
+      (block aborted
+	(setf r
+	      (flet ((%do
+		      ()
+		      (if *compile-tests*
+			  (multiple-value-list
+			   (funcall (compile
+				     nil
+				     `(lambda ()
+					(declare
+					 (optimize ,@*optimization-settings*))
+					,(form entry)))))
+			(multiple-value-list
+			 (eval (form entry))))))
+		(if *catch-errors*
+		    (handler-bind
+			((style-warning #'muffle-warning)
+			 (error #'(lambda (c)
+				    (setf aborted t)
+				    (setf r (list c))
+				    (return-from aborted nil))))
+		      (%do))
+		  (%do)))))
+
+      (setf (pend entry)
+	    (or aborted
+		(not (equalp-with-case r (vals entry)))))
+      
+      (when (pend entry)
+	(let ((*print-circle* *print-circle-on-failure*))
+	  (format s "~&Test ~:@(~S~) failed~
+                   ~%Form: ~S~
+                   ~%Expected value~P: ~
+                      ~{~S~^~%~17t~}~%"
+		  *test* (form entry)
+		  (length (vals entry))
+		  (vals entry))
+	  (format s "Actual value~P: ~
+                      ~{~S~^~%~15t~}.~%"
+		  (length r) r)))))
+  (when (not (pend entry)) *test*))
+
+(defun continue-testing ()
+  (if *in-test*
+      (throw '*in-test* nil)
+      (do-entries *standard-output*)))
+
+(defun do-tests (&optional
+		 (out *standard-output*))
+  (dolist (entry (cdr *entries*))
+    (setf (pend entry) t))
+  (if (streamp out)
+      (do-entries out)
+      (with-open-file 
+	  (stream out :direction :output)
+	(do-entries stream))))
+
+(defun do-entries (s)
+  (format s "~&Doing ~A pending test~:P ~
+             of ~A tests total.~%"
+          (count t (cdr *entries*)
+		 :key #'pend)
+	  (length (cdr *entries*)))
+  (dolist (entry (cdr *entries*))
+    (when (pend entry)
+      (format s "~@[~<~%~:; ~:@(~S~)~>~]"
+	      (do-entry entry s))))
+  (let ((pending (pending-tests))
+	(expected-table (make-hash-table :test #'equal)))
+    (dolist (ex *expected-failures*)
+      (setf (gethash ex expected-table) t))
+    (let ((new-failures
+	   (loop for pend in pending
+		 unless (gethash pend expected-table)
+		 collect pend)))
+      (if (null pending)
+	  (format s "~&No tests failed.")
+	(progn
+	  (format s "~&~A out of ~A ~
+                   total tests failed: ~
+                   ~:@(~{~<~%   ~1:;~S~>~
+                         ~^, ~}~)."
+		  (length pending)
+		  (length (cdr *entries*))
+		  pending)
+	  (if (null new-failures)
+	      (format s "~&No unexpected failures.")
+	    (when *expected-failures*
+	      (format s "~&~A unexpected failures: ~
+                   ~:@(~{~<~%   ~1:;~S~>~
+                         ~^, ~}~)."
+		    (length new-failures)
+		    new-failures)))
+	  ))
+      (finish-output s)
+      (null pending))))

contrib/sockets/test.lisp

@@ -0,0 +1,244 @@
+(in-package :cl-user)
+
+(load "sys:sockets")
+(load "../rt/rt")
+
+(use-package :sb-bsd-sockets)
+(use-package :sb-rt)
+
+;;; a real address
+(deftest make-inet-address
+  (equalp (make-inet-address "127.0.0.1")  #(127 0 0 1))
+  t)
+;;; and an address with bit 8 set on some octets
+(deftest make-inet-address2
+  (equalp (make-inet-address "242.1.211.3")  #(242 1 211 3))
+  t)
+
+(deftest make-inet-socket
+  ;; make a socket
+  (let ((s (make-instance 'inet-socket :type :stream :protocol (get-protocol-by-name "tcp"))))
+    (and (> (socket-file-descriptor s) 1) t))
+  t)
+
+(deftest make-inet-socket-keyword
+    ;; make a socket
+    (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp)))
+      (and (> (socket-file-descriptor s) 1) t))
+  t)
+
+(deftest make-inet-socket-wrong
+    ;; fail to make a socket: check correct error return.  There's no nice
+    ;; way to check the condition stuff on its own, which is a shame
+    (handler-case
+	(make-instance 'inet-socket :type :stream :protocol (get-protocol-by-name "udp"))
+      ((or socket-type-not-supported-error protocol-not-supported-error) (c)
+	(declare (ignorable c)) t)
+      (:no-error nil))
+  t)
+
+(deftest make-inet-socket-keyword-wrong
+    ;; same again with keywords
+    (handler-case
+	(make-instance 'inet-socket :type :stream :protocol :udp)
+      ((or protocol-not-supported-error socket-type-not-supported-error) (c)
+	(declare (ignorable c)) t)
+      (:no-error nil))
+  t)
+
+
+(deftest non-block-socket
+  (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp)))
+    (setf (non-blocking-mode s) t)
+    (non-blocking-mode s))
+  t)
+
+(defun do-gc-portably ()
+  ;; cmucl on linux has generational gc with a keyword argument,
+  ;; sbcl GC function takes same arguments no matter what collector is in
+  ;; use
+  #+(or sbcl gencgc) (SB-EXT:gc :full t)
+  #+ecl (ext:gc t)
+  ;; other platforms have full gc or nothing
+  #-(or sbcl gencgc ecl) (sb-ext:gc))
+
+(deftest inet-socket-bind
+  (let ((s (make-instance 'inet-socket :type :stream :protocol (get-protocol-by-name "tcp"))))
+    ;; Given the functions we've got so far, if you can think of a
+    ;; better way to make sure the bind succeeded than trying it
+    ;; twice, let me know
+    ;; 1974 has no special significance, unless you're the same age as me
+    (do-gc-portably) ;gc should clear out any old sockets bound to this port
+    (socket-bind s (make-inet-address "127.0.0.1") 1974)
+    (handler-case
+	(let ((s2 (make-instance 'inet-socket :type :stream :protocol (get-protocol-by-name "tcp"))))
+	  (socket-bind s2 (make-inet-address "127.0.0.1") 1974)
+	  nil)
+      (address-in-use-error () t)))
+  t)
+
+(deftest simple-sockopt-test
+  ;; test we can set SO_REUSEADDR on a socket and retrieve it, and in
+  ;; the process that all the weird macros in sockopt happened right.
+  (let ((s (make-instance 'inet-socket :type :stream :protocol (get-protocol-by-name "tcp"))))
+    (setf (sockopt-reuse-address s) t)
+    (sockopt-reuse-address s))
+  t)
+
+(defun read-buf-nonblock (buffer stream)
+  "Like READ-SEQUENCE, but returns early if the full quantity of data isn't there to be read.  Blocks if no input at all"
+  (let ((eof (gensym)))
+    (do ((i 0 (1+ i))
+         (c (read-char stream nil eof)
+            (read-char-no-hang stream nil eof)))
+        ((or (>= i (length buffer)) (not c) (eq c eof)) i)
+      (setf (elt buffer i) c))))
+
+(deftest name-service-return-type
+  (vectorp (host-ent-address (get-host-by-address #(127 0 0 1))))
+  t)
+
+;;; these require that the echo services are turned on in inetd
+(deftest simple-tcp-client
+    (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp))
+	  (data (make-string 200)))
+      (socket-connect s #(127 0 0 1) 7)
+      (let ((stream (socket-make-stream s :input t :output t :buffering :none)))
+	(format stream "here is some text")
+	(let ((data (subseq data 0 (read-buf-nonblock data stream))))
+	  (format t "~&Got ~S back from TCP echo server~%" data)
+	  (> (length data) 0))))
+  t)
+
+(deftest sockaddr-return-type
+  (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp)))
+    (unwind-protect 
+	 (progn
+	   (socket-connect s #(127 0 0 1) 7)
+	   (multiple-value-bind (host port) (socket-peername s)
+	     (and (vectorp host)
+		  (numberp port))))
+      (socket-close s)))
+  t)
+
+(deftest simple-udp-client
+  (let ((s (make-instance 'inet-socket :type :datagram :protocol (get-protocol-by-name "udp")))
+        (data (make-string 200)))
+    (format t "Socket type is ~A~%" (sockopt-type s))
+    (socket-connect s #(127 0 0 1) 7)
+    (let ((stream (socket-make-stream s :input t :output t :buffering :none)))
+      (format stream "here is some text")
+      (finish-output stream)
+      (let ((data (subseq data 0 (read-buf-nonblock data stream))))
+	(format t "~&Got ~S back from UDP echo server~%" data)
+	(> (length data) 0))))
+  t)
+
+;;; A fairly rudimentary test that connects to the syslog socket and
+;;; sends a message.  Priority 7 is kern.debug; you'll probably want
+;;; to look at /etc/syslog.conf or local equivalent to find out where
+;;; the message ended up
+(deftest simple-local-client
+    (progn
+      ;; SunOS (Solaris) and Darwin systems don't have a socket at
+      ;; /dev/log.  We might also be building in a chroot or
+      ;; something, so don't fail this test just because the file is
+      ;; unavailable, or if it's a symlink to some weird character
+      ;; device.
+      (when (and (probe-file "/dev/log")
+		 #-ecl
+		 (sb-posix:s-issock
+		  (sb-posix::stat-mode (sb-posix:stat "/dev/log"))))
+	(let ((s (make-instance 'local-socket :type :datagram)))
+	  (format t "Connecting ~A... " s)
+	  (finish-output)
+	  (handler-case
+	      (socket-connect s "/dev/log")
+	    (socket-error ()
+	      (setq s (make-instance 'local-socket :type :stream))
+	      (format t "failed~%Retrying with ~A... " s)
+	      (finish-output)
+	      (socket-connect s "/dev/log")))
+	  (format t "ok.~%")
+	  (let ((stream (socket-make-stream s :input t :output t :buffering :none)))
+	    (format stream
+		    "<7>sb-bsd-sockets: Don't panic.  We're testing local-domain client code; this message can safely be ignored"))))
+      t)
+  t)
+
+
+;;; these require that the internet (or bits of it, at least) is available
+
+(deftest get-host-by-name
+  (equalp (car (host-ent-addresses (get-host-by-name "a.root-servers.net")))
+          #(198 41 0 4))
+  t)
+
+(deftest get-host-by-address
+    (host-ent-name (get-host-by-address #(198 41 0 4)))
+  "a.root-servers.net")
+
+(deftest get-host-by-name-wrong
+  (handler-case
+   (get-host-by-name "foo.tninkpad.telent.net")
+   (NAME-SERVICE-ERROR () t)
+   (:no-error nil))
+  t)
+
+(defun http-stream (host port request)
+  (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp)))
+    (socket-connect
+     s (car (host-ent-addresses (get-host-by-name host))) port)
+    (let ((stream (socket-make-stream s :input t :output t :buffering :none)))
+      (format stream "~A HTTP/1.0~%~%" request))
+    s))
+
+(deftest simple-http-client-1
+    (handler-case
+	(let ((s (http-stream "ww.telent.net" 80 "HEAD /")))
+	  (let ((data (make-string 200)))
+	    (setf data (subseq data 0
+			       (read-buf-nonblock data
+						  (socket-make-stream s))))
+	    (princ data)
+	    (> (length data) 0)))
+      (network-unreachable-error () 'network-unreachable))
+  t)
+
+
+(deftest sockopt-receive-buffer
+    ;; on Linux x86, the receive buffer size appears to be doubled in the
+    ;; kernel: we set a size of x and then getsockopt() returns 2x.
+    ;; This is why we compare with >= instead of =
+    (handler-case
+	(let ((s (http-stream "ww.telent.net" 80 "HEAD /")))
+	  (setf (sockopt-receive-buffer s) 1975)
+	  (let ((data (make-string 200)))
+	    (setf data (subseq data 0
+			       (read-buf-nonblock data
+						  (socket-make-stream s))))
+	    (and (> (length data) 0)
+		 (>= (sockopt-receive-buffer s) 1975))))
+      (network-unreachable-error () 'network-unreachable))
+  t)
+
+
+;;; we don't have an automatic test for some of this yet.  There's no
+;;; simple way to run servers and have something automatically connect
+;;; to them as client, unless we spawn external programs.  Then we
+;;; have to start telling people what external programs they should
+;;; have installed.  Which, eventually, we will, but not just yet
+
+
+;;; to check with this: can display packets from multiple peers
+;;; peer address is shown correctly for each packet
+;;; packet length is correct
+;;; long (>500 byte) packets have the full length shown (doesn't work)
+
+(defun udp-server (port)
+  (let ((s (make-instance 'inet-socket :type :datagram :protocol :udp)))
+    (socket-bind s #(0 0 0 0) port)
+    (loop
+     (multiple-value-bind (buf len address port) (socket-receive s nil 500)
+       (format t "Received ~A bytes from ~A:~A - ~A ~%"
+	       len address port (subseq buf 0 (min 10 len)))))))

src/CHANGELOG

@@ -41,6 +41,13 @@ ECL 0.9f
 
  - When *PRINT-READABLY*=T, vectors just print as arrays.
 
+* Contributed modules:
+
+ - MIT test unit rt.lisp is now available as #p"sys:rt"
+
+ - SBCL sockets have been ported to unix (J. Stecklina) and to windows
+   (M. Goffioul) and are built when using the configuration option --with-tcp.
+
 ;;; Local Variables: ***
 ;;; mode:text ***
 ;;; fill-column:79 ***

src/Makefile.in

@@ -89,6 +89,9 @@ ecl-config: ecl-config.pre
 sysfun.lsp:
 	ln -s -f $(srcdir)/cmp/sysfun.lsp ./
 
+rt.lisp:
+	cp $(srcdir)/../contrib/rt/rt.lisp ./
+
 BUILD-STAMP: config.status
 	(echo "#"; uname -a) > $@
 	head -8 config.status | tail -6 >> $@

src/bare.lsp.in

@@ -9,6 +9,7 @@
 ;;;   find headers and libraries in the build directory.
 ;;;
 (si::pathname-translations "SRC" `(("**;*.*.*" "@true_srcdir@/**/*.*")))
+(si::pathname-translations "EXT" `(("**;*.*.*" "@true_srcdir@/../contrib/**/*.*")))
 (si::pathname-translations "BUILD" `(("**;*.*.*" "@true_builddir@/**/*.*")))
 (si::pathname-translations "SYS" '(("**;*.*.*" "@true_builddir@/**/*.*")))
 
@@ -55,6 +56,8 @@
 ;;; * Timed compilation facility.
 ;;;
 (defun compile-if-old (destdir sources &rest options)
+  (unless (probe-file destdir)
+    (si::mkdir destdir #o0777))
   (mapcar #'(lambda (source)
 	      (let ((object (merge-pathnames destdir (compile-file-pathname source :type :object))))
 		(unless (and (probe-file object)

src/c/cinit.d

@@ -64,6 +64,9 @@ main(int argc, char **args)
 #endif
 #ifdef CLX
 	SYM_VAL(@'*features*') = CONS(make_keyword("WANTS-CLX"), SYM_VAL(@'*features*'));
+#endif
+#ifdef TCP
+	SYM_VAL(@'*features*') = CONS(make_keyword("WANTS-SOCKETS"), SYM_VAL(@'*features*'));
 #endif
 	top_level = _intern("TOP-LEVEL", cl_core.system_package);
 	cl_def_c_function(top_level, si_simple_toplevel, 0);

src/compile.lsp.in

@@ -124,6 +124,24 @@ ranlib ../@LIBPREFIX@ecl.@LIBEXT@'")
    ;;:shared-data-file "build:cmp.sdat"
    ))
 
+;;;
+;;; * Sockets library.
+;;;
+
+(defconstant +sockets-module-files+
+'("ext:sockets;sockets.lisp"))
+
+(setq si::*init-function-prefix* "EXT")
+
+#+WANTS-SOCKETS
+(progn
+  (proclaim '(optimize (safety 2) (speed 1)))
+  (let* ((objects (compile-if-old "build:ext;" +sockets-module-files+
+				  :system-p t :c-file t :data-file t :h-file t)))
+    (c::build-static-library "sockets" :lisp-files objects)
+    #+dlopen
+    (c::build-fasl "sockets" :lisp-files objects)))
+
 ;;;
 ;;; * Compile the portable CLX library.
 ;;;
@@ -156,8 +174,6 @@ ranlib ../@LIBPREFIX@ecl.@LIBEXT@'")
 (progn
   (proclaim '(optimize (safety 2) (speed 1)))
   (push :clx-ansi-common-lisp *features*)
-  (unless (probe-file "build:clx;")
-    (si::mkdir "build:clx;" #o0777))
   (mapcar #'load +clx-module-files+)
   (let* ((objects (compile-if-old "build:clx;" +clx-module-files+
 				  :system-p t :c-file t :data-file t :h-file t)))
@@ -171,5 +187,6 @@ ranlib ../@LIBPREFIX@ecl.@LIBEXT@'")
  #+(or cross stage1) "ecl"
  #-(or cross stage1) "ecl2"
  :lisp-files '(#+(and (not dlopen) WANTS-CMP) cmp
+	       #+(and (not dlopen) WANTS-SOCKETS) sockets
 	       #+(and (not dlopen) WANTS-CLX) clx)
  :ld-flags '(#-msvc "-L./"))

src/configure.in

@@ -243,12 +243,17 @@ fi
 if test "${tcp}" -o "${clx}"; then
   AC_DEFINE(TCP)
   EXTRA_OBJS="${EXTRA_OBJS} tcp.${OBJEXT}"
+  if test ${shared} = "yes" ; then
+    LSP_LIBRARIES="${LSP_LIBRARIES} sockets.fas"
+  else
+    LSP_LIBRARIES="${LSP_LIBRARIES} ${LIBPREFIX}sockets.${LIBEXT}"
+  fi
   CLIBS="${CLIBS} ${TCPLIBS}"
 fi
 if test "${oldloop}"; then
   AC_DEFINE(ECL_OLD_LOOP)
 fi
-if test "${cmuformat}"; then
+if test "${cmuformat}" = "yes"; then
   closstreams="yes"
   AC_DEFINE(ECL_CMU_FORMAT)
 fi