sbcl stuff
This commit is contained in:
Ian Keane
parent
1d1dbc34df
commit
5d91dbb667
335 changed files with 119806 additions and 1 deletions
|
|
@ -0,0 +1,11 @@
|
|||
;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: CL-USER -*-
|
||||
;;;; See the LICENSE file for licensing information.
|
||||
|
||||
(in-package :cl-user)
|
||||
|
||||
(defpackage :usocket-test
|
||||
(:use :common-lisp
|
||||
:usocket
|
||||
:regression-test)
|
||||
(:export #:do-tests
|
||||
#:run-usocket-tests))
|
||||
|
|
@ -0,0 +1,28 @@
|
|||
;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: USOCKET-TEST -*-
|
||||
;;;; See LICENSE for licensing information.
|
||||
|
||||
(in-package :usocket-test)
|
||||
|
||||
(deftest ns-host-not-found-error.1
|
||||
(with-caught-conditions (usocket:ns-host-not-found-error nil)
|
||||
(usocket:socket-connect "xxx" 123)
|
||||
t)
|
||||
nil)
|
||||
|
||||
(deftest timeout-error.1
|
||||
(with-caught-conditions (usocket:timeout-error nil)
|
||||
(usocket:socket-connect "common-lisp.net" 81 :timeout 0)
|
||||
t)
|
||||
nil)
|
||||
|
||||
(deftest connection-refused-error.1
|
||||
(with-caught-conditions (usocket:connection-refused-error nil)
|
||||
(usocket:socket-connect "common-lisp.net" 81)
|
||||
t)
|
||||
nil)
|
||||
|
||||
(deftest operation-not-permitted-error.1
|
||||
(with-caught-conditions (usocket:operation-not-permitted-error nil)
|
||||
(usocket:socket-listen "0.0.0.0" 81)
|
||||
t)
|
||||
nil)
|
||||
|
|
@ -0,0 +1,124 @@
|
|||
;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: USOCKET-TEST -*-
|
||||
;;;; See LICENSE for licensing information.
|
||||
|
||||
(in-package :usocket-test)
|
||||
|
||||
(defvar *echo-server*)
|
||||
(defvar *echo-server-port*)
|
||||
|
||||
(defun start-server ()
|
||||
(multiple-value-bind (thread socket)
|
||||
(socket-server "127.0.0.1" 0 #'identity nil
|
||||
:in-new-thread t
|
||||
:protocol :datagram)
|
||||
(setq *echo-server* thread
|
||||
*echo-server-port* (get-local-port socket))))
|
||||
|
||||
(defparameter *max-buffer-size* 32)
|
||||
|
||||
(defvar *send-buffer*
|
||||
(make-array *max-buffer-size* :element-type '(unsigned-byte 8) :initial-element 0))
|
||||
|
||||
(defvar *receive-buffer*
|
||||
(make-array *max-buffer-size* :element-type '(unsigned-byte 8) :initial-element 0))
|
||||
|
||||
(defun clean-buffers ()
|
||||
(fill *send-buffer* 0)
|
||||
(fill *receive-buffer* 0))
|
||||
|
||||
;;; UDP Send Test #1: connected socket
|
||||
(deftest udp-send.1
|
||||
(progn
|
||||
(unless (and *echo-server* *echo-server-port*)
|
||||
(start-server))
|
||||
(let ((s (socket-connect "127.0.0.1" *echo-server-port* :protocol :datagram)))
|
||||
(clean-buffers)
|
||||
(replace *send-buffer* #(1 2 3 4 5))
|
||||
(socket-send s *send-buffer* 5)
|
||||
(wait-for-input s :timeout 3)
|
||||
(multiple-value-bind (buffer size host port)
|
||||
(socket-receive s *receive-buffer* *max-buffer-size*)
|
||||
(declare (ignore buffer size host port))
|
||||
(reduce #'+ *receive-buffer* :start 0 :end 5))))
|
||||
15)
|
||||
|
||||
;;; UDP Send Test #2: unconnected socket
|
||||
(deftest udp-send.2
|
||||
(progn
|
||||
(unless (and *echo-server* *echo-server-port*)
|
||||
(start-server))
|
||||
(let ((s (socket-connect nil nil :protocol :datagram)))
|
||||
(clean-buffers)
|
||||
(replace *send-buffer* #(1 2 3 4 5))
|
||||
(socket-send s *send-buffer* 5 :host "127.0.0.1" :port *echo-server-port*)
|
||||
(wait-for-input s :timeout 3)
|
||||
(multiple-value-bind (buffer size host port)
|
||||
(socket-receive s *receive-buffer* *max-buffer-size*)
|
||||
(declare (ignore buffer size host port))
|
||||
(reduce #'+ *receive-buffer* :start 0 :end 5))))
|
||||
15)
|
||||
|
||||
(deftest mark-h-david ; Mark H. David's remarkable UDP test code
|
||||
(let* ((host "localhost")
|
||||
(port 1111)
|
||||
(server-sock
|
||||
(socket-connect nil nil :protocol ':datagram :local-host host :local-port port))
|
||||
(client-sock
|
||||
(socket-connect host port :protocol ':datagram))
|
||||
(octet-vector
|
||||
(make-array 2 :element-type '(unsigned-byte 8) :initial-contents `(,(char-code #\O) ,(char-code #\K))))
|
||||
(recv-octet-vector
|
||||
(make-array 2 :element-type '(unsigned-byte 8))))
|
||||
(socket-send client-sock octet-vector 2)
|
||||
(socket-receive server-sock recv-octet-vector 2)
|
||||
(prog1 (and (equalp octet-vector recv-octet-vector)
|
||||
recv-octet-vector)
|
||||
(socket-close server-sock)
|
||||
(socket-close client-sock)))
|
||||
#(79 75))
|
||||
|
||||
(deftest frank-james ; Frank James' test code for LispWorks/UDP
|
||||
(with-caught-conditions (#+win32 CONNECTION-RESET-ERROR
|
||||
#-win32 CONNECTION-REFUSED-ERROR
|
||||
nil)
|
||||
(let ((sock (socket-connect "localhost" 1234
|
||||
:protocol ':datagram :element-type '(unsigned-byte 8))))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(socket-send sock (make-array 16 :element-type '(unsigned-byte 8) :initial-element 0) 16)
|
||||
(let ((buffer (make-array 16 :element-type '(unsigned-byte 8) :initial-element 0)))
|
||||
(socket-receive sock buffer 16)))
|
||||
(socket-close sock))))
|
||||
nil)
|
||||
|
||||
(defun frank-wfi-test ()
|
||||
(let ((s (socket-connect nil nil :protocol :datagram
|
||||
:element-type '(unsigned-byte 8)
|
||||
:local-port 8001)))
|
||||
(unwind-protect
|
||||
(do ((i 0 (1+ i))
|
||||
(buffer (make-array 1024 :element-type '(unsigned-byte 8)
|
||||
:initial-element 0))
|
||||
(now (get-universal-time))
|
||||
(done nil))
|
||||
((or done (= i 4))
|
||||
nil)
|
||||
(format t "~Ds ~D Waiting state ~S~%" (- (get-universal-time) now) i (usocket::state s))
|
||||
(when (wait-for-input s :ready-only t :timeout 5)
|
||||
(format t "~D state ~S~%" i (usocket::state s))
|
||||
(handler-bind
|
||||
((error (lambda (c)
|
||||
(format t "socket-receive error: ~A~%" c)
|
||||
(break)
|
||||
nil)))
|
||||
(multiple-value-bind (buffer count remote-host remote-port)
|
||||
(socket-receive s buffer 1024)
|
||||
(handler-bind
|
||||
((error (lambda (c)
|
||||
(format t "socket-send error: ~A~%" c)
|
||||
(break))))
|
||||
(when buffer
|
||||
(socket-send s (subseq buffer 0 count) count
|
||||
:host remote-host
|
||||
:port remote-port)))))))
|
||||
(socket-close s))))
|
||||
|
|
@ -0,0 +1,179 @@
|
|||
;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: USOCKET-TEST -*-
|
||||
;;;; See LICENSE for licensing information.
|
||||
|
||||
;;;; Usage: (usoct:run-usocket-tests) or (usoct:do-tests)
|
||||
|
||||
(in-package :usocket-test)
|
||||
|
||||
(defparameter +non-existing-host+ "1.2.3.4")
|
||||
(defparameter +unused-local-port+ 15213)
|
||||
|
||||
(defparameter *fake-usocket*
|
||||
(usocket::make-stream-socket :socket :my-socket
|
||||
:stream :my-stream))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(defvar *common-lisp-net*
|
||||
(get-host-by-name "common-lisp.net")))
|
||||
|
||||
(defvar *local-ip*)
|
||||
|
||||
(defmacro with-caught-conditions ((expect throw) &body body)
|
||||
`(catch 'caught-error
|
||||
(handler-case
|
||||
(handler-bind ((unsupported
|
||||
#'(lambda (c)
|
||||
(declare (ignore c)) (continue))))
|
||||
(progn ,@body))
|
||||
(unknown-error (c) (if (typep c ',expect)
|
||||
(throw 'caught-error ,throw)
|
||||
(progn
|
||||
(describe c)
|
||||
(describe
|
||||
(usocket::usocket-real-error c))
|
||||
c)))
|
||||
(error (c) (if (typep c ',expect)
|
||||
(throw 'caught-error ,throw)
|
||||
(progn
|
||||
(describe c)
|
||||
c)))
|
||||
(unknown-condition (c) (if (typep c ',expect)
|
||||
(throw 'caught-error ,throw)
|
||||
(progn
|
||||
(describe c)
|
||||
(describe
|
||||
(usocket::usocket-real-condition c))
|
||||
c)))
|
||||
(condition (c) (if (typep c ',expect)
|
||||
(throw 'caught-error ,throw)
|
||||
(progn
|
||||
(describe c)
|
||||
c))))))
|
||||
|
||||
(deftest make-socket.1 (socket *fake-usocket*) :my-socket)
|
||||
(deftest make-socket.2 (socket-stream *fake-usocket*) :my-stream)
|
||||
|
||||
(deftest socket-no-connect.1
|
||||
(with-caught-conditions (socket-error nil)
|
||||
(socket-connect "127.0.0.1" +unused-local-port+ :timeout 1)
|
||||
t)
|
||||
nil)
|
||||
|
||||
(deftest socket-no-connect.2
|
||||
(with-caught-conditions (socket-error nil)
|
||||
(socket-connect #(127 0 0 1) +unused-local-port+ :timeout 1)
|
||||
t)
|
||||
nil)
|
||||
|
||||
(deftest socket-no-connect.3
|
||||
(with-caught-conditions (socket-error nil)
|
||||
(socket-connect 2130706433 +unused-local-port+ :timeout 1) ;; == #(127 0 0 1)
|
||||
t)
|
||||
nil)
|
||||
|
||||
(deftest socket-failure.1
|
||||
(with-caught-conditions (timeout-error nil)
|
||||
(socket-connect 2130706433 +unused-local-port+ :timeout 1) ;; == #(127 0 0 1)
|
||||
:unreach)
|
||||
nil)
|
||||
|
||||
(deftest socket-failure.2
|
||||
(with-caught-conditions (timeout-error nil)
|
||||
(socket-connect +non-existing-host+ 80 :timeout 1) ;; 80 = just a port
|
||||
:unreach)
|
||||
nil)
|
||||
|
||||
;; let's hope c-l.net doesn't move soon, or that people start to
|
||||
;; test usocket like crazy..
|
||||
(deftest socket-connect.1
|
||||
(with-caught-conditions (nil nil)
|
||||
(let ((sock (socket-connect "common-lisp.net" 80)))
|
||||
(unwind-protect
|
||||
(when (typep sock 'usocket) t)
|
||||
(socket-close sock))))
|
||||
t)
|
||||
|
||||
(deftest socket-connect.2
|
||||
(with-caught-conditions (nil nil)
|
||||
(let ((sock (socket-connect *common-lisp-net* 80)))
|
||||
(unwind-protect
|
||||
(when (typep sock 'usocket) t)
|
||||
(socket-close sock))))
|
||||
t)
|
||||
|
||||
(deftest socket-connect.3
|
||||
(with-caught-conditions (nil nil)
|
||||
(let ((sock (socket-connect (usocket::host-byte-order *common-lisp-net*) 80)))
|
||||
(unwind-protect
|
||||
(when (typep sock 'usocket) t)
|
||||
(socket-close sock))))
|
||||
t)
|
||||
|
||||
;; let's hope c-l.net doesn't change its software any time soon
|
||||
(deftest socket-stream.1
|
||||
(with-caught-conditions (nil nil)
|
||||
(let ((sock (socket-connect "common-lisp.net" 80)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(format (socket-stream sock)
|
||||
"GET / HTTP/1.0~2%")
|
||||
(force-output (socket-stream sock))
|
||||
(subseq (read-line (socket-stream sock)) 0 4))
|
||||
(socket-close sock))))
|
||||
"HTTP")
|
||||
|
||||
(deftest socket-name.1
|
||||
(with-caught-conditions (nil nil)
|
||||
(let ((sock (socket-connect *common-lisp-net* 80)))
|
||||
(unwind-protect
|
||||
(get-peer-address sock)
|
||||
(socket-close sock))))
|
||||
#.*common-lisp-net*)
|
||||
|
||||
(deftest socket-name.2
|
||||
(with-caught-conditions (nil nil)
|
||||
(let ((sock (socket-connect *common-lisp-net* 80)))
|
||||
(unwind-protect
|
||||
(get-peer-port sock)
|
||||
(socket-close sock))))
|
||||
80)
|
||||
|
||||
(deftest socket-name.3
|
||||
(with-caught-conditions (nil nil)
|
||||
(let ((sock (socket-connect *common-lisp-net* 80)))
|
||||
(unwind-protect
|
||||
(get-peer-name sock)
|
||||
(socket-close sock))))
|
||||
#.*common-lisp-net* 80)
|
||||
|
||||
#+ignore
|
||||
(deftest socket-name.4
|
||||
(with-caught-conditions (nil nil)
|
||||
(let ((sock (socket-connect *common-lisp-net* 80)))
|
||||
(unwind-protect
|
||||
(equal (get-local-address sock) *local-ip*)
|
||||
(socket-close sock))))
|
||||
t)
|
||||
|
||||
(deftest socket-shutdown.1
|
||||
(with-caught-conditions (nil nil)
|
||||
(let ((sock (socket-connect *common-lisp-net* 80)))
|
||||
(unwind-protect
|
||||
(usocket::ignore-unsupported-warnings
|
||||
(socket-shutdown sock :input))
|
||||
(socket-close sock))
|
||||
t))
|
||||
t)
|
||||
|
||||
(deftest socket-shutdown.2
|
||||
(with-caught-conditions (nil nil)
|
||||
(let ((sock (socket-connect *common-lisp-net* 80)))
|
||||
(unwind-protect
|
||||
(usocket::ignore-unsupported-warnings
|
||||
(socket-shutdown sock :output))
|
||||
(socket-close sock))
|
||||
t))
|
||||
t)
|
||||
|
||||
(defun run-usocket-tests ()
|
||||
(do-tests))
|
||||
|
|
@ -0,0 +1,86 @@
|
|||
;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: USOCKET-TEST -*-
|
||||
|
||||
(in-package :usocket-test)
|
||||
|
||||
;; Test code from "INVALID-ARGUMENT-ERROR on socket-receive (#48)"
|
||||
|
||||
;; Author: @4lph4-Ph4un
|
||||
;; Environment: SBCL 1.4.16, WSL on Windows 10
|
||||
|
||||
(defun UDP-one-shot-V1 (&optional (port 1232))
|
||||
(let ((socket (usocket:socket-connect
|
||||
nil
|
||||
nil
|
||||
:protocol :datagram
|
||||
:element-type '(unsigned-byte 8)
|
||||
:local-host "127.0.0.1"
|
||||
:local-port port))
|
||||
(buffer (make-array 8 :element-type '(unsigned-byte 8))))
|
||||
(unwind-protect
|
||||
(multiple-value-bind (received size remote-host remote-port)
|
||||
;; NOTE: An explicit buffer can be given. If the length
|
||||
;; is nil buffer's length will be used.
|
||||
(usocket:socket-receive socket buffer 8)
|
||||
(format t "~A~%" received)
|
||||
(usocket:socket-send socket
|
||||
(reverse received)
|
||||
size
|
||||
:host remote-host
|
||||
:port remote-port))
|
||||
(usocket:socket-close socket))))
|
||||
|
||||
#|
|
||||
Backtrace:
|
||||
0: (USOCKET::HANDLE-CONDITION #<SB-BSD-SOCKETS:INVALID-ARGUMENT-ERROR {100375B833}> #<USOCKET:DATAGRAM-USOCKET {100375B773}>)
|
||||
Locals:
|
||||
CONDITION = #<SB-BSD-SOCKETS:INVALID-ARGUMENT-ERROR {100375B833}>
|
||||
SOCKET = #<USOCKET:DATAGRAM-USOCKET {100375B773}>
|
||||
1: (SB-KERNEL::%SIGNAL #<SB-BSD-SOCKETS:INVALID-ARGUMENT-ERROR {100375B833}>)
|
||||
Locals:
|
||||
CONDITION = #<SB-BSD-SOCKETS:INVALID-ARGUMENT-ERROR {100375B833}>
|
||||
HANDLER-CLUSTERS = (((#<SB-KERNEL::CLASSOID-CELL SB-IMPL::EVAL-ERROR> . #<CLOSURE # {7F0C5FD9DE0B}>)) ((#<SB-KERNEL::CLASSOID-CELL SB-C:COMPILER-ERROR> . #<FUNCTION # {5222748B}>)) ..)
|
||||
2: (ERROR SB-BSD-SOCKETS:INVALID-ARGUMENT-ERROR :ERRNO 22 :SYSCALL "recvfrom")
|
||||
Locals:
|
||||
CONDITION = #<SB-BSD-SOCKETS:INVALID-ARGUMENT-ERROR {100375B833}>
|
||||
#:G8039 = SB-BSD-SOCKETS:INVALID-ARGUMENT-ERROR
|
||||
SB-DEBUG::MORE = (:ERRNO 22 :SYSCALL "recvfrom")
|
||||
3: (SB-BSD-SOCKETS:SOCKET-ERROR "recvfrom" 22)
|
||||
Locals:
|
||||
ERRNO = 22
|
||||
WHERE = "recvfrom"
|
||||
4: ((FLET SB-BSD-SOCKETS::WITH-SOCKET-ADDR-THUNK :IN SB-BSD-SOCKETS:SOCKET-RECEIVE) #<SB-ALIEN-INTERNALS:ALIEN-VALUE :SAP #X7F0C58001230 :TYPE (* (SB-ALIEN:STRUCT SB-BSD-SOCKETS-INTERNAL::SOCKADDR-IN (SB..
|
||||
Locals:
|
||||
SB-BSD-SOCKETS::COPY-BUFFER = #<SB-ALIEN-INTERNALS:ALIEN-VALUE :SAP #X7F0C58001250 :TYPE (* (ARRAY (SB-ALIEN:UNSIGNED 8) 1))>
|
||||
SB-BSD-SOCKETS::SIZE = 16
|
||||
SB-BSD-SOCKETS::SOCKADDR = #<SB-ALIEN-INTERNALS:ALIEN-VALUE :SAP #X7F0C58001230 :TYPE (* ..)>
|
||||
5: (SB-BSD-SOCKETS::CALL-WITH-SOCKET-ADDR #<SB-BSD-SOCKETS:INET-SOCKET 127.0.0.1:1232, fd: 3 {100375B203}> NIL #<CLOSURE (FLET SB-BSD-SOCKETS::WITH-SOCKET-ADDR-THUNK :IN SB-BSD-SOCKETS:SOCKET-RECEIVE) {7..
|
||||
Locals:
|
||||
SOCKADDR = #<SB-ALIEN-INTERNALS:ALIEN-VALUE :SAP #X7F0C58001230 :TYPE (* ..)>
|
||||
SOCKADDR-ARGS = NIL
|
||||
SOCKET = #<SB-BSD-SOCKETS:INET-SOCKET 127.0.0.1:1232, fd: 3 {100375B203}>
|
||||
THUNK = #<CLOSURE (FLET SB-BSD-SOCKETS::WITH-SOCKET-ADDR-THUNK :IN SB-BSD-SOCKETS:SOCKET-RECEIVE) {7F0C5FD9DB8B}>
|
||||
6: ((:METHOD SB-BSD-SOCKETS:SOCKET-RECEIVE (SB-BSD-SOCKETS:SOCKET T T)) #<SB-BSD-SOCKETS:INET-SOCKET 127.0.0.1:1232, fd: 3 {100375B203}> #(0 0 0 0 0 0 ...) 8 :OOB NIL :PEEK NIL :WAITALL NIL :DONTWAIT NIL..
|
||||
Locals:
|
||||
#:.DEFAULTING-TEMP. = (UNSIGNED-BYTE 8)
|
||||
SB-BSD-SOCKETS::BUFFER = #(0 0 0 0 0 0 ...)
|
||||
SB-BSD-SOCKETS::BUFFER#1 = #(0 0 0 0 0 0 ...)
|
||||
SB-BSD-SOCKETS::DONTWAIT = NIL
|
||||
SB-BSD-SOCKETS::ELEMENT-TYPE = (UNSIGNED-BYTE 8)
|
||||
LENGTH = 8
|
||||
LENGTH#1 = 8
|
||||
SB-BSD-SOCKETS::OOB = NIL
|
||||
SB-BSD-SOCKETS::PEEK = NIL
|
||||
SB-BSD-SOCKETS:SOCKET = #<SB-BSD-SOCKETS:INET-SOCKET 127.0.0.1:1232, fd: 3 {100375B203}>
|
||||
SB-BSD-SOCKETS::WAITALL = NIL
|
||||
7: ((:METHOD USOCKET:SOCKET-RECEIVE (USOCKET:DATAGRAM-USOCKET T T)) #<USOCKET:DATAGRAM-USOCKET {100375B773}> #(0 0 0 0 0 0 ...) 8 :ELEMENT-TYPE (UNSIGNED-BYTE 8)) [fast-method]
|
||||
Locals:
|
||||
USOCKET::BUFFER = #(0 0 0 0 0 0 ...)
|
||||
USOCKET::ELEMENT-TYPE = (UNSIGNED-BYTE 8)
|
||||
LENGTH = 8
|
||||
USOCKET:SOCKET = #<USOCKET:DATAGRAM-USOCKET {100375B773}>
|
||||
8: (MASTER-CLASS/SRC/SERVER-03:UDP-ONE-SHOT-V1 1232)
|
||||
Locals:
|
||||
PORT = 1232
|
||||
SOCKET = #<USOCKET:DATAGRAM-USOCKET {100375B773}>
|
||||
|#
|
||||
|
||||
|
|
@ -0,0 +1,140 @@
|
|||
;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: USOCKET-TEST -*-
|
||||
;;;; See LICENSE for licensing information.
|
||||
|
||||
(in-package :usocket-test)
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(defparameter *wait-for-input-timeout* 2))
|
||||
|
||||
(deftest wait-for-input.1
|
||||
(with-caught-conditions (nil nil)
|
||||
(let ((sock (usocket:socket-connect *common-lisp-net* 80))
|
||||
(time (get-universal-time)))
|
||||
(unwind-protect
|
||||
(progn (usocket:wait-for-input sock :timeout *wait-for-input-timeout*)
|
||||
(- (get-universal-time) time))
|
||||
(usocket:socket-close sock))))
|
||||
#.*wait-for-input-timeout*)
|
||||
|
||||
(deftest wait-for-input.2
|
||||
(with-caught-conditions (nil nil)
|
||||
(let ((sock (usocket:socket-connect *common-lisp-net* 80))
|
||||
(time (get-universal-time)))
|
||||
(unwind-protect
|
||||
(progn (usocket:wait-for-input sock :timeout *wait-for-input-timeout* :ready-only t)
|
||||
(- (get-universal-time) time))
|
||||
(usocket:socket-close sock))))
|
||||
#.*wait-for-input-timeout*)
|
||||
|
||||
(deftest wait-for-input.3
|
||||
(with-caught-conditions (nil nil)
|
||||
(let ((sock (usocket:socket-connect *common-lisp-net* 80)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(format (usocket:socket-stream sock)
|
||||
"GET / HTTP/1.0~2%")
|
||||
(force-output (usocket:socket-stream sock))
|
||||
(usocket:wait-for-input sock :timeout *wait-for-input-timeout*)
|
||||
(subseq (read-line (usocket:socket-stream sock)) 0 4))
|
||||
(usocket:socket-close sock))))
|
||||
"HTTP")
|
||||
|
||||
;;; Advanced W-F-I tests by Elliott Slaughter <elliottslaughter@gmail.com>
|
||||
|
||||
(defvar *socket-server-port* 0)
|
||||
(defvar *socket-server-listen* nil)
|
||||
(defvar *socket-server-connection*)
|
||||
(defvar *socket-client-connection*)
|
||||
(defvar *output-p* t)
|
||||
|
||||
(defun stage-1 ()
|
||||
(unless *socket-server-listen*
|
||||
(setf *socket-server-listen*
|
||||
(socket-listen *wildcard-host* 0 :element-type '(unsigned-byte 8)))
|
||||
(setf *socket-server-port* (get-local-port *socket-server-listen*)))
|
||||
|
||||
(setf *socket-server-connection*
|
||||
(when (wait-for-input *socket-server-listen* :timeout 0 :ready-only t)
|
||||
(socket-accept *socket-server-listen*)))
|
||||
|
||||
(when *output-p* ; should be NIL
|
||||
(format t "First time (before client connects) is ~s.~%"
|
||||
*socket-server-connection*))
|
||||
|
||||
*socket-server-connection*)
|
||||
|
||||
;; TODO: original test code have addition (:TIMEOUT 0) when doing the SOCKET-CONNECT,
|
||||
;; it seems cannot work on SBCL/Windows, need to investigate, but here we ignore it.
|
||||
|
||||
(defun stage-2 ()
|
||||
(setf *socket-client-connection*
|
||||
(socket-connect "localhost" *socket-server-port* :protocol :stream
|
||||
:element-type '(unsigned-byte 8)))
|
||||
(setf *socket-server-connection*
|
||||
(when (wait-for-input *socket-server-listen* :timeout 0 :ready-only t)
|
||||
#+(and win32 (or lispworks ecl sbcl))
|
||||
(when *output-p*
|
||||
(format t "%READY-P: ~D~%" (usocket::%ready-p *socket-server-listen*)))
|
||||
(socket-accept *socket-server-listen*)))
|
||||
|
||||
(when *output-p* ; should be a usocket object
|
||||
(format t "Second time (after client connects) is ~s.~%"
|
||||
*socket-server-connection*))
|
||||
|
||||
*socket-server-connection*)
|
||||
|
||||
(defun stage-3 ()
|
||||
(setf *socket-server-connection*
|
||||
(when (wait-for-input *socket-server-listen* :timeout 0 :ready-only t)
|
||||
#+(and win32 (or lispworks ecl sbcl))
|
||||
(when *output-p*
|
||||
(format t "%READY-P: ~D~%" (usocket::%ready-p *socket-server-listen*)))
|
||||
(socket-accept *socket-server-listen*)))
|
||||
|
||||
(when *output-p* ; should be NIL again
|
||||
(format t "Third time (before second client) is ~s.~%"
|
||||
*socket-server-connection*))
|
||||
|
||||
*socket-server-connection*)
|
||||
|
||||
(deftest elliott-slaughter.1
|
||||
(let ((*output-p* nil))
|
||||
(let* ((s-1 (stage-1)) (s-2 (stage-2)) (s-3 (stage-3)))
|
||||
(prog1 (and (null s-1) (usocket::usocket-p s-2) (null s-3))
|
||||
(socket-close *socket-server-listen*)
|
||||
(setf *socket-server-listen* nil))))
|
||||
t)
|
||||
|
||||
#|
|
||||
|
||||
Issue elliott-slaughter.2 (WAIT-FOR-INPUT/win32 on TCP socket)
|
||||
|
||||
W-F-I correctly found the inputs, but :READY-ONLY didn't work.
|
||||
|
||||
|#
|
||||
(defun receive-each (connections)
|
||||
(let ((ready (usocket:wait-for-input connections :timeout 0 :ready-only t)))
|
||||
(loop for connection in ready
|
||||
collect (read-line (usocket:socket-stream connection)))))
|
||||
|
||||
(defun receive-all (connections)
|
||||
(loop for messages = (receive-each connections)
|
||||
then (receive-each connections)
|
||||
while messages append messages))
|
||||
|
||||
(defun send (connection message)
|
||||
(format (usocket:socket-stream connection) "~a~%" message)
|
||||
(force-output (usocket:socket-stream connection)))
|
||||
|
||||
(defun server ()
|
||||
(let* ((listen (usocket:socket-listen usocket:*wildcard-host* 12345))
|
||||
(connection (usocket:socket-accept listen)))
|
||||
(loop for messages = (receive-all connection) then (receive-all connection)
|
||||
do (format t "Got messages:~%~s~%" messages)
|
||||
do (sleep 1/50))))
|
||||
|
||||
(defun client ()
|
||||
(let ((connection (usocket:socket-connect "localhost" 12345)))
|
||||
(loop for i from 0
|
||||
do (send connection (format nil "This is message ~a." i))
|
||||
do (sleep 1/100))))
|
||||
Loading…
Add table
Add a link
Reference in a new issue