February 2008 - usocket-cvs@common-lisp.net

[usocket-cvs] r321 - usocket/trunk/backend
by ehuelsmann＠common-lisp.net 28 Feb '08

28 Feb '08

Author: ehuelsmann Date: Thu Feb 28 02:30:01 2008 New Revision: 321 Modified: usocket/trunk/backend/clisp.lisp Log: Preliminary implementation of datagram sockets send(to)/recv(from) functions. TODO: - Adjust WAIT-FOR-INPUT - Think of a name to instantiate datagram sockets - Make sure the functions which retrieve local and remote socket names work with datagram sockets Modified: usocket/trunk/backend/clisp.lisp ============================================================================== --- usocket/trunk/backend/clisp.lisp (original) +++ usocket/trunk/backend/clisp.lisp Thu Feb 28 02:30:01 2008 @@ -145,3 +145,69 @@ (when y x)) sockets status-list)))))) + +;; +;; UDP/Datagram sockets! +;; + +#+rawsock +(progn + + (defun make-sockaddr_in () + (make-array 16 :element-type '(unsigned-byte 8) :initial-element 0)) + + (declaim (inline fill-sockaddr_in)) + (defun fill-sockaddr_in (sockaddr_in ip port) + (port-to-octet-buffer sockaddr_in port) + (ip-to-octet-buffer sockaddr_in ip :start 2) + sockaddr_in) + + (defun socket-receive (socket buffer &key (size (length buffer))) + "Returns the buffer, the number of octets copied into the buffer (received) +and the address of the sender as values." + (let* ((sock (socket socket)) + (sockaddr (when (not (connected-p socket)) + (rawsock:make-sockaddr))) + (rv (if sockaddr + (rawsock:recvfrom sock buffer sockaddr + :start 0 + :end size) + (rawsock:recv sock buffer + :start 0 + :end size)))) + (values buffer + rv + (list (ip-from-octet-buffer (sockaddr-data sockaddr) 4) + (port-from-octet-buffer (sockaddr-data sockaddr) 2))))) + + (defun socket-send (socket buffer &key address (size (length buffer))) + "Returns the number of octets sent." + (let* ((sock (socket socket)) + (sockaddr (when address + (rawsock:make-sockaddr :INET + (fill-sockaddr_in + (make-sockaddr_in) + (host-byte-order + (second address)) + (first address))))) + (rv (if address + (rawsock:sendto sock buffer sockaddr + :start 0 + :end size) + (rawsock:send sock buffer + :start 0 + :end size)))) + rv)) + + (defmethod socket-close ((usocket datagram-usocket)) + (rawsock:socket-close (socket usocket))) + + ) + +#-rawsock +(progn + (warn "This image doesn't contain the RAWSOCK package. +To enable UDP socket support, please be sure to use the -Kfull parameter +at startup, or to enable RAWSOCK support during compilation.") + + ) \ No newline at end of file

1 0

[usocket-cvs] r320 - usocket/trunk
by ehuelsmann＠common-lisp.net 21 Feb '08

21 Feb '08

Author: ehuelsmann Date: Thu Feb 21 15:29:19 2008 New Revision: 320 Modified: usocket/trunk/usocket.asd Log: Update version identifier, as 0.4.x has branched now, we're working toward 0.5.0. Modified: usocket/trunk/usocket.asd ============================================================================== --- usocket/trunk/usocket.asd (original) +++ usocket/trunk/usocket.asd Thu Feb 21 15:29:19 2008 @@ -14,7 +14,7 @@ (defsystem usocket :name "usocket" :author "Erik Enge & Erik Huelsmann" - :version "0.4.0-dev" + :version "0.5.0-dev" :licence "MIT" :description "Universal socket library for Common Lisp" :depends-on (:split-sequence

1 0

[usocket-cvs] r319 - usocket/trunk
by ehuelsmann＠common-lisp.net 20 Feb '08

20 Feb '08

Author: ehuelsmann Date: Wed Feb 20 16:47:46 2008 New Revision: 319 Modified: usocket/trunk/package.lisp usocket/trunk/usocket.lisp Log: Introduce datagram socket and several utility functions. Modified: usocket/trunk/package.lisp ============================================================================== --- usocket/trunk/package.lisp (original) +++ usocket/trunk/package.lisp Wed Feb 20 16:47:46 2008 @@ -33,6 +33,7 @@ #:stream-server-usocket #:socket #:socket-stream + #:datagram-usocket #:host-byte-order ; IP(v4) utility functions #:hbo-to-dotted-quad @@ -42,6 +43,13 @@ #:ip= #:ip/= + #:integer-to-octet-buffer ; Network utility functions + #:octet-buffer-to-integer + #:port-to-octet-buffer + #:port-from-octet-buffer + #:ip-to-octet-buffer + #:ip-from-octet-buffer + #:socket-condition ; conditions #:ns-condition #:socket-error ; errors Modified: usocket/trunk/usocket.lisp ============================================================================== --- usocket/trunk/usocket.lisp (original) +++ usocket/trunk/usocket.lisp Wed Feb 20 16:47:46 2008 @@ -73,13 +73,11 @@ (typep socket 'stream-server-usocket)) (defun datagram-usocket-p (socket) - (declare (ignore socket)) - nil) + (typep socket 'datagram-usocket)) -;;Not in use yet: -;;(defclass datagram-usocket (usocket) -;; () -;; (:documentation "")) +(defclass datagram-usocket (usocket) + ((connected-p :initarg :connected-p :accessor connected-p)) + (:documentation "")) (defun make-socket (&key socket) "Create a usocket socket type from implementation specific socket." @@ -235,6 +233,42 @@ (when (< elapsed timeout) (- timeout elapsed))))))) + +;; +;; Data utility functions +;; + +(defun integer-to-octet-buffer (integer buffer octets &key (start 0)) + (do ((b start (1+ b)) + (i (ash (1- octets) 3) ;; * 8 + (- i 8))) + ((> 0 i) buffer) + (setf (aref buffer b) + (ldb (byte 8 i) integer)))) + +(defun octet-buffer-to-integer (buffer octets &key (start 0)) + (let ((integer 0)) + (do ((b start (1+ b)) + (i (ash (1- octets) 3) ;; * 8 + (- i 8))) + ((> 0 i) + integer) + (setf (ldb (byte 8 i) integer) + (aref buffer b))))) + + +(defmacro port-to-octet-buffer (port buffer &key (start 0)) + `(integer-to-octet-buffer ,port ,buffer 2 ,start)) + +(defmacro ip-to-octet-buffer (ip buffer &key (start 0)) + `(integer-to-octet-buffer (host-byte-order ,ip) ,buffer 4 ,start)) + +(defmacro port-from-octet-buffer (buffer &key (start 0)) + `(octet-buffer-to-integer ,buffer 2 ,start)) + +(defmacro ip-from-octet-buffer (buffer &key (start 0)) + `(octet-buffer-to-integer ,buffer 4 ,start)) + ;; ;; IP(v4) utility functions ;;

1 0

[usocket-cvs] r318 - usocket/branches/0.4.x
by ehuelsmann＠common-lisp.net 20 Feb '08

20 Feb '08

Author: ehuelsmann Date: Wed Feb 20 16:38:47 2008 New Revision: 318 Added: usocket/branches/0.4.x/ - copied from r317, usocket/trunk/ Log: Make way on trunk for development of UDP sockets interfaces by creating a WAIT-FOR-INPUT branch (0.4.x).

1 0

[usocket-cvs] r317 - usocket/trunk/backend
by ehuelsmann＠common-lisp.net 17 Feb '08

17 Feb '08

Author: ehuelsmann Date: Sun Feb 17 16:40:31 2008 New Revision: 317 Modified: usocket/trunk/backend/sbcl.lisp Log: Fix nameservice condition/error names; also revert some of r307: fast-unix-select *does* return errno, but change the code a bit to prevent the compiler from issueing warnings. Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp (original) +++ usocket/trunk/backend/sbcl.lisp Sun Feb 17 16:40:31 2008 @@ -162,8 +162,8 @@ ;; Nameservice errors: mapped to unknown-error (sb-bsd-sockets:no-recovery-error . ns-no-recovery-error) - (sb-bsd-sockets:try-again-condition . ns-try-again-condition) - (sb-bsd-sockets:host-not-found . ns-host-not-found-error))) + (sb-bsd-sockets:try-again-error . ns-try-again-condition) + (sb-bsd-sockets:host-not-found-error . ns-host-not-found-error))) (defun handle-condition (condition &optional (socket nil)) "Dispatch correct usocket condition." @@ -279,25 +279,24 @@ (multiple-value-bind (secs musecs) (split-timeout (or timeout 1)) - (let ((count - (sb-unix:unix-fast-select - (1+ (reduce #'max (mapcar #'socket sockets) - :key #'sb-bsd-sockets:socket-file-descriptor)) - (sb-alien:addr rfds) nil nil - (when timeout secs) musecs))) - (unless (= 0 count) ;; 0 means timeout - (if (=> count 0) + (multiple-value-bind + (count err) + (sb-unix:unix-fast-select + (1+ (reduce #'max (mapcar #'socket sockets) + :key #'sb-bsd-sockets:socket-file-descriptor)) + (sb-alien:addr rfds) nil nil + (when timeout secs) musecs) + (if (null count) + (unless (= err sb-unix:EINTR) + (error (map-errno-error err))) + (when (< 0 count) ;; process the result... (remove-if #'(lambda (x) - (not - (sb-unix:fd-isset - (sb-bsd-sockets:socket-file-descriptor (socket x)) - rfds))) - sockets) - (let ((err (sb-alien:get-errno))) - (unless (= err sb-unix:EINTR) - (error (map-errno-error err))))))))))) + (not (sb-unix:fd-isset + (sb-bsd-sockets:socket-file-descriptor (socket x)) + rfds))) + sockets)))))))) #+win32 (warn "wait-for-input not (yet!) supported...")

1 0

[usocket-cvs] r316 - in usocket/trunk: . backend
by ehuelsmann＠common-lisp.net 17 Feb '08

17 Feb '08

Author: ehuelsmann Date: Sun Feb 17 14:29:16 2008 New Revision: 316 Modified: usocket/trunk/backend/lispworks.lisp usocket/trunk/usocket.lisp Log: Take alternate approach on LW: We don't know whether the internals depend on WSAEnumNetworkEvents(), but if we use that function, the internals can't work correctly anymore: it clears the socket state. So, for the stream socket (the one type supported by LispWorks), resort to trickery to establish whether there are octets to be read from the network buffer. Modified: usocket/trunk/backend/lispworks.lisp ============================================================================== --- usocket/trunk/backend/lispworks.lisp (original) +++ usocket/trunk/backend/lispworks.lisp Sun Feb 17 14:29:16 2008 @@ -45,11 +45,13 @@ (defun raise-or-signal-socket-error (errno socket) (let ((usock-err (cdr (assoc errno +lispworks-error-map+ :test #'member)))) - (when usock-err ;; don't claim the error when we're not sure - ;; it's actually sockets related + (if usock-err (if (subtypep usock-err 'error) (error usock-err :socket socket) - (signal usock-err :socket))))) + (signal usock-err :socket)) + (error 'unknown-error + :socket socket + :real-condition nil)))) (defun raise-usock-err (errno socket &optional condition) (let* ((usock-err @@ -105,6 +107,9 @@ :direction :io :element-type (or element-type (element-type usocket))))) + #+win32 + (when sock + (setf (%ready-p usocket) nil)) (make-stream-socket :socket sock :stream stream))) ;; Sockets and their streams are different objects @@ -148,9 +153,7 @@ (comm:get-host-entry name :fields '(:addresses))))) (defun os-socket-handle (usocket) - (if (stream-usocket-p usocket) - (comm:socket-stream-socket (socket usocket)) - (socket usocket))) + (socket usocket)) (defun usocket-listen (usocket) (if (stream-usocket-p usocket) @@ -223,6 +226,8 @@ (defconstant fd-max-events 10) + (defconstant fionread 1074030207) + (fli:define-foreign-type ws-socket () '(:unsigned :int)) (fli:define-foreign-type win32-handle () '(:unsigned :int)) (fli:define-c-struct wsa-network-events (network-events :long) @@ -234,7 +239,7 @@ :result-type :int :module "ws2_32") (fli:define-foreign-function (wsa-event-close "WSACloseEvent" :source) - (event-object win32-handle) + ((event-object win32-handle)) :result-type :int :module "ws2_32") (fli:define-foreign-function (wsa-enum-network-events "WSAEnumNetworkEvents" :source) @@ -256,6 +261,15 @@ :result-type :int :module "ws2_32") + (fli:define-foreign-function (wsa-ioctlsocket "ioctlsocket" :source) + ((socket :long) (cmd :long) (argp (:ptr :long))) + :result-type :int + :module "ws2_32") + + + ;; The Windows system + + ;; Now that we have access to the system calls, this is the plan: ;; 1. Receive a list of sockets to listen to @@ -271,6 +285,13 @@ (unless (zerop rv) (raise-usock-err (wsa-get-last-error) socket))) + (defun bytes-available-for-read (socket) + (fli:with-dynamic-foreign-objects ((int-ptr :long)) + (let ((rv (wsa-ioctlsocket (os-socket-handle socket) fionread int-ptr))) + (if (= 0 rv) + (fli:dereference int-ptr) + 0)))) + (defun add-socket-to-event (socket event-object) (let ((events (etypecase socket (stream-server-usocket (logior fd-connect fd-accept fd-close)) @@ -279,52 +300,51 @@ (wsa-event-select (os-socket-handle socket) event-object events) socket))) - (defun wait-for-sockets (sockets timeout) + (defun socket-ready-p (socket) + (if (typep socket 'stream-usocket) + (< 0 (bytes-available-for-read socket)) + (%ready-p socket))) + + (defun waiting-required (sockets) + (notany #'socket-ready-p sockets)) + + (defun wait-for-input-internal (sockets &key timeout) (let ((event-object (wsa-event-create))) (unwind-protect (progn - (dolist (socket sockets) - (add-socket-to-event socket event-object)) - (system:wait-for-single-object event-object - "Waiting for socket activity" timeout)) - (maybe-wsa-error - (wsa-event-close event-object) - nil)))) - + (when (waiting-required sockets) + (dolist (socket sockets) + (add-socket-to-event socket event-object)) + (system:wait-for-single-object event-object + "Waiting for socket activity" timeout)) + (update-ready-slots sockets) + (sockets-ready sockets)) + (wsa-event-close event-object)))) (defun map-network-events (func network-events) (let ((event-map (fli:foreign-slot-value network-events 'network-events)) - (error-array (fli:foreign-slot-value network-events 'error-code))) + (error-array (fli:foreign-slot-pointer network-events 'error-code))) (unless (zerop event-map) - (dotimes (i fd-max-events) - (unless (zerop (ldb (byte 1 i) event-map)) - (funcall func (fli:foreign-aref error-array i))))))) + (dotimes (i fd-max-events) + (unless (zerop (ldb (byte 1 i) event-map)) + (funcall func (fli:foreign-aref error-array i))))))) + + (defun update-ready-slots (sockets) + (dolist (socket sockets) + (unless (or (stream-usocket-p socket) ;; no need to check status for streams + (%ready-p socket)) ;; and sockets already marked ready + (multiple-value-bind + (rv network-events) + (wsa-enum-network-events (os-socket-handle socket) 0 t) + (if (zerop rv) + (map-network-events #'(lambda (err-code) + (if (zerop err-code) + (setf (%ready-p socket) t) + (raise-usock-err err-code socket))) + network-events) + (maybe-wsa-error rv socket)))))) (defun sockets-ready (sockets) - (remove-if-not - #'(lambda (socket) - (multiple-value-bind - (rv network-events) - (wsa-enum-network-events (os-socket-handle socket) 0) - (if (zerop rv) - (let ((non-error-state-p nil)) - ;; raise any errors we find - (map-network-events - #'(lambda (err-code) - (if (zerop err-code) - (setf non-error-statep t) - (let ((err-class (map-errno-error err-code))) - (if (subtypep err-class 'socket-error) - (error err-class :socket socket) - (error err-class))))) - network-events) - ;; return whether we found non-error state - non-error-state-p) - (maybe-wsa-error rv socket)))) - sockets)) - - (defun wait-for-input-internal (sockets &key timeout) - (wait-for-sockets sockets timeout) - (sockets-ready sockets)) - + (remove-if-not #'socket-ready-p sockets)) + );; end of WIN32-block Modified: usocket/trunk/usocket.lisp ============================================================================== --- usocket/trunk/usocket.lisp (original) +++ usocket/trunk/usocket.lisp Sun Feb 17 14:29:16 2008 @@ -45,7 +45,21 @@ #+lispworks 'base-char :reader element-type :documentation "Default element type for streams created by -`socket-accept'.")) +`socket-accept'.") + #+(and lispworks win32) + (%ready-p + :initform nil + :accessor %ready-p + :documentation "Indicates whether the socket has been signalled +as ready for reading a new connection. + +The value will be set to T by `wait-for-input-internal' (given the +right conditions) and reset to NIL by `socket-accept'. + +Don't modify this slot or depend on it as it is really intended +to be internal only. +" + )) (:documentation "Socket which listens for stream connections to be initiated from remote sockets."))

1 0

[usocket-cvs] r315 - usocket/trunk/backend
by ehuelsmann＠common-lisp.net 17 Feb '08

17 Feb '08

Author: ehuelsmann Date: Sun Feb 17 07:46:10 2008 New Revision: 315 Modified: usocket/trunk/backend/lispworks.lisp Log: Remove obsolete HAS-NON-ERROR-STATE-P and HAS-NETWORK-ERRORS-P. Modified: usocket/trunk/backend/lispworks.lisp ============================================================================== --- usocket/trunk/backend/lispworks.lisp (original) +++ usocket/trunk/backend/lispworks.lisp Sun Feb 17 07:46:10 2008 @@ -300,20 +300,6 @@ (unless (zerop (ldb (byte 1 i) event-map)) (funcall func (fli:foreign-aref error-array i))))))) - (defun has-network-errors-p (network-events) - (map-network-events #'(lambda (err-code) - (unless (zerop err-code) - (return-from has-network-errors-p t))) - network-events) - nil) - - (defun has-non-error-state-p (network-events) - (map-network-events #'(lambda (err-code) - (when (zerop err-code) - (return-from has-non-error-state-p t))) - network-errors) - nil) - (defun sockets-ready (sockets) (remove-if-not #'(lambda (socket)

1 0

[usocket-cvs] r314 - usocket/trunk/backend
by ehuelsmann＠common-lisp.net 17 Feb '08

17 Feb '08

Author: ehuelsmann Date: Sun Feb 17 07:44:47 2008 New Revision: 314 Modified: usocket/trunk/backend/lispworks.lisp Log: Clean up LW backend for socket waiting: - rename MAP-NETWORK-ERRORS to MAP-NETWORK-EVENTS - reimplement more lispy HAS-NETWORK-ERRORS-P (record for posterity, as it's now unused) - change implementation of SOCKETS-READY to use MAP-NETWORK-EVENTS Modified: usocket/trunk/backend/lispworks.lisp ============================================================================== --- usocket/trunk/backend/lispworks.lisp (original) +++ usocket/trunk/backend/lispworks.lisp Sun Feb 17 07:44:47 2008 @@ -292,38 +292,50 @@ nil)))) - (defun map-network-errors (func network-events) + (defun map-network-events (func network-events) (let ((event-map (fli:foreign-slot-value network-events 'network-events)) (error-array (fli:foreign-slot-value network-events 'error-code))) - (dotimes (i fd-max-events) - (unless (zerop (ldb (byte 1 i) event-map)) - (funcall func (fli:foreign-aref error-array i)))))) + (unless (zerop event-map) + (dotimes (i fd-max-events) + (unless (zerop (ldb (byte 1 i) event-map)) + (funcall func (fli:foreign-aref error-array i))))))) (defun has-network-errors-p (network-events) - (let ((network-events (fli:foreign-slot-value network-events 'network-events)) - (error-array (fli:foreign-slot-value network-events 'error-code))) - ;; We need to check the bits before checking the error: - ;; the api documents the consumer can only assume valid values for - ;; fields which have the corresponding bit set - (do ((i 0 (1+ i))) - ((and (< i fd-max-events) - (not (zerop (ldb (byte 1 i) network-events))) - (zerop (fli:foreign-aref error-array i))) - (< i fd-max-events))))) - - (defun socket-ready-p (network-events) - (and (not (zerop (fli:foreign-slot-value network-events 'network-events))) - (not (has-network-errors-p network-events)))) + (map-network-events #'(lambda (err-code) + (unless (zerop err-code) + (return-from has-network-errors-p t))) + network-events) + nil) + + (defun has-non-error-state-p (network-events) + (map-network-events #'(lambda (err-code) + (when (zerop err-code) + (return-from has-non-error-state-p t))) + network-errors) + nil) (defun sockets-ready (sockets) - (remove-if-not #'(lambda (socket) - (multiple-value-bind - (rv network-events) - (wsa-enum-network-events (os-socket-handle socket) 0) - (if (zerop rv) - (socket-ready-p network-events) - (maybe-wsa-error rv socket)))) - sockets)) + (remove-if-not + #'(lambda (socket) + (multiple-value-bind + (rv network-events) + (wsa-enum-network-events (os-socket-handle socket) 0) + (if (zerop rv) + (let ((non-error-state-p nil)) + ;; raise any errors we find + (map-network-events + #'(lambda (err-code) + (if (zerop err-code) + (setf non-error-statep t) + (let ((err-class (map-errno-error err-code))) + (if (subtypep err-class 'socket-error) + (error err-class :socket socket) + (error err-class))))) + network-events) + ;; return whether we found non-error state + non-error-state-p) + (maybe-wsa-error rv socket)))) + sockets)) (defun wait-for-input-internal (sockets &key timeout) (wait-for-sockets sockets timeout)

1 0

[usocket-cvs] r313 - usocket/trunk/backend
by ehuelsmann＠common-lisp.net 17 Feb '08

17 Feb '08

Author: ehuelsmann Date: Sun Feb 17 04:37:57 2008 New Revision: 313 Modified: usocket/trunk/backend/lispworks.lisp Log: Adapt LW backend WAIT-FOR-INPUT-INTERNAL to new general behaviour in caller, which already adjusts TIMEOUT. Modified: usocket/trunk/backend/lispworks.lisp ============================================================================== --- usocket/trunk/backend/lispworks.lisp (original) +++ usocket/trunk/backend/lispworks.lisp Sun Feb 17 04:37:57 2008 @@ -326,14 +326,7 @@ sockets)) (defun wait-for-input-internal (sockets &key timeout) - (wait-for-sockets sockets - (if (some #'(lambda (x) - (and (stream-usocket-p x) - (listen (socket-stream x)))) - sockets) - 0 ;; don't wait: there are streams which - ;; can be read from, even if not from the socket - timeout) + (wait-for-sockets sockets timeout) (sockets-ready sockets)) );; end of WIN32-block

1 0

[usocket-cvs] r312 - usocket/trunk/backend
by ehuelsmann＠common-lisp.net 17 Feb '08

17 Feb '08

Author: ehuelsmann Date: Sun Feb 17 04:29:37 2008 New Revision: 312 Modified: usocket/trunk/backend/sbcl.lisp Log: Fix ECL error reporting: we need to map an errno-error, not a socket-error. Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp (original) +++ usocket/trunk/backend/sbcl.lisp Sun Feb 17 04:29:37 2008 @@ -323,5 +323,5 @@ (socket s)) result-fds))) sockets) - (map-socket-error err))))))) + (error (map-errno-error err)))))))) )

1 0