Fixed up Unix sockets a bit. master
authorFredrik Tolf <fredrik@dolda2000.com>
Sun, 15 Aug 2010 07:40:47 +0000 (09:40 +0200)
committerFredrik Tolf <fredrik@dolda2000.com>
Sun, 15 Aug 2010 07:40:47 +0000 (09:40 +0200)
 * Support anonymous addresses.
 * Clean up bound names when closing.

common-net.lisp
net-ecl.lisp
net-sb-bsd.lisp

index 10fc919..57a5b84 100644 (file)
 ;;; Unix sockets
 
 (defclass local-address (address)
 ;;; Unix sockets
 
 (defclass local-address (address)
-  ((path :type pathname)))
+  ((path :type (or pathname nil))))
 
 (defmethod initialize-instance :after ((instance local-address) &key path)
 
 (defmethod initialize-instance :after ((instance local-address) &key path)
-  (setf (slot-value instance 'path) (pathname path)))
+  (setf (slot-value instance 'path) (and path (pathname path))))
 
 (defmethod format-address ((address local-address))
 
 (defmethod format-address ((address local-address))
-  (namestring (slot-value address 'path)))
+  (let ((path (slot-value address 'path)))
+    (and path (namestring path))))
 
 (defclass local-stream-address (local-address) ())
 (defclass local-seq-address (local-address) ())
 
 (defclass local-stream-address (local-address) ())
 (defclass local-seq-address (local-address) ())
index 3f80737..3388954 100644 (file)
@@ -71,3 +71,8 @@
 
 (defmethod gray:stream-write-sequence ((socket stream-socket) seq &optional (start 0) (end (length seq)))
   (gray-stream-write-sequence socket seq start end))
 
 (defmethod gray:stream-write-sequence ((socket stream-socket) seq &optional (start 0) (end (length seq)))
   (gray-stream-write-sequence socket seq start end))
+
+;;; Error cover-up
+
+(defmethod sb-bsd-sockets:socket-name ((sk sb-bsd-sockets:local-socket))
+  (simple-network-error "ECL does not support reading the name of Unix sockets."))
index 9c757c5..3d2affd 100644 (file)
@@ -5,6 +5,11 @@
 (defclass sbcl-listen-socket (listen-socket sbcl-socket) ())
 (defclass sbcl-stream-socket (stream-socket sbcl-socket) ())
 (defclass sbcl-datagram-socket (datagram-socket sbcl-socket) ())
 (defclass sbcl-listen-socket (listen-socket sbcl-socket) ())
 (defclass sbcl-stream-socket (stream-socket sbcl-socket) ())
 (defclass sbcl-datagram-socket (datagram-socket sbcl-socket) ())
+(defclass sbcl-unix-socket (sbcl-socket)
+  ((unlink-name :type (or pathname nil) :initform nil)))
+(defclass sbcl-unix-listen-socket (sbcl-listen-socket sbcl-unix-socket) ())
+(defclass sbcl-unix-stream-socket (sbcl-stream-socket sbcl-unix-socket) ())
+(defclass sbcl-unix-datagram-socket (sbcl-datagramx-socket sbcl-unix-socket) ())
 
 (defmacro with-sb-socket ((var socket) &body body)
   (let ((success (gensym "SUCCESS")))
 
 (defmacro with-sb-socket ((var socket) &body body)
   (let ((success (gensym "SUCCESS")))
     (error 'socket-closed :socket socket)))
 
 (defgeneric socket-class-for-address (address mode))
     (error 'socket-closed :socket socket)))
 
 (defgeneric socket-class-for-address (address mode))
-(defmethod socket-class-for-address ((address tcp-address) (mode (eql :connect))) 'sbcl-stream-socket)
+(defmethod socket-class-for-address ((address tcp-address) mode) 'sbcl-stream-socket)
 (defmethod socket-class-for-address ((address tcp-address) (mode (eql :bind))) 'sbcl-listen-socket)
 (defmethod socket-class-for-address ((address udp-address) mode) 'sbcl-datagram-socket)
 (defmethod socket-class-for-address ((address inet-host-address) mode) 'sbcl-datagram-socket)
 (defmethod socket-class-for-address ((address tcp-address) (mode (eql :bind))) 'sbcl-listen-socket)
 (defmethod socket-class-for-address ((address udp-address) mode) 'sbcl-datagram-socket)
 (defmethod socket-class-for-address ((address inet-host-address) mode) 'sbcl-datagram-socket)
-(defmethod socket-class-for-address ((address local-stream-address) mode) 'sbcl-stream-socket)
-(defmethod socket-class-for-address ((address local-seq-address) mode) 'sbcl-datagram-socket)
-(defmethod socket-class-for-address ((address local-datagram-address) mode) 'sbcl-datagram-socket)
+(defmethod socket-class-for-address ((address local-stream-address) mode) 'sbcl-unix-stream-socket)
+(defmethod socket-class-for-address ((address local-stream-address) (mode (eql :bind))) 'sbcl-unix-listen-socket)
+(defmethod socket-class-for-address ((address local-seq-address) mode) 'sbcl-unix-datagram-socket)
+(defmethod socket-class-for-address ((address local-seq-address) (mode (eql :bind))) 'sbcl-unix-listen-socket)
+(defmethod socket-class-for-address ((address local-datagram-address) mode) 'sbcl-unix-datagram-socket)
 
 (define-condition wrapped-socket-error (error socket-condition)
   ((cause :initarg :cause))
 
 (define-condition wrapped-socket-error (error socket-condition)
   ((cause :initarg :cause))
 (defmethod socket-send-to ((socket sbcl-socket) buf destination &key (start 0) (end (length buf)) from no-hang)
   (check-not-closed socket)
   (when from
 (defmethod socket-send-to ((socket sbcl-socket) buf destination &key (start 0) (end (length buf)) from no-hang)
   (check-not-closed socket)
   (when from
-    (simple-network-error "SB-BSD-THREADS does not support specifying the source address of individual packets."))
+    (simple-network-error "SB-BSD-SOCKETS does not support specifying the source address of individual packets."))
   (let ((result (map-sb-bsd-errors (socket)
                  (retry-loop ("Retry the send operation.")
                    (sb-bsd-sockets:socket-send (slot-value socket 'sb-socket)
   (let ((result (map-sb-bsd-errors (socket)
                  (retry-loop ("Retry the send operation.")
                    (sb-bsd-sockets:socket-send (slot-value socket 'sb-socket)
                                  (apply #'sb-bsd-sockets:socket-connect sk (map-address-to-sbcl sk remote))))
                              sk)))
 
                                  (apply #'sb-bsd-sockets:socket-connect sk (map-address-to-sbcl sk remote))))
                              sk)))
 
+(defmethod bind-to-address :around ((address local-address))
+  (let ((ret (call-next-method)))
+    (when (typep ret 'sbcl-unix-socket)
+      (setf (slot-value ret 'unlink-name) (slot-value address 'path)))
+    ret))
+
+(defmethod connect-to-address :around ((remote local-address) &key local)
+  (let ((ret (call-next-method)))
+    (when (and (typep ret 'sbcl-unix-socket) (typep local 'local-address))
+      (setf (slot-value ret 'unlink-name) (slot-value local 'path)))
+    ret))
+
 (defmethod accept ((socket sbcl-listen-socket))
   (check-not-closed socket)
   (let* ((ret-list (multiple-value-list (sb-bsd-sockets:socket-accept (slot-value socket 'sb-socket))))
         (sk (first ret-list))
         (addr-list (rest ret-list)))
     (with-sb-socket (sk sk)
 (defmethod accept ((socket sbcl-listen-socket))
   (check-not-closed socket)
   (let* ((ret-list (multiple-value-list (sb-bsd-sockets:socket-accept (slot-value socket 'sb-socket))))
         (sk (first ret-list))
         (addr-list (rest ret-list)))
     (with-sb-socket (sk sk)
-      (values (make-instance 'sbcl-stream-socket :sb-socket sk)
+      (values (make-instance 'sbcl-stream-socket
+                            ;; XXX: Should be
+                            ;; (socket-class-for-address (map-sbcl-to-address sk (multiple-value-list (sb-bsd-sockets:socket-name sk))) :accept)
+                            ;; but ECL does not support socket-name for Unix sockets.
+                            :sb-socket sk)
              (map-sbcl-to-address sk addr-list)))))
              (map-sbcl-to-address sk addr-list)))))
+
+(defmethod close-socket :after ((socket sbcl-unix-socket))
+  (with-slots (unlink-name) socket
+    (when unlink-name
+      (delete-file unlink-name)
+      (setf unlink-name nil))))