From 808457cb2af9dac048727de6b089d6d81235d29e Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Thu, 1 Apr 2010 12:52:04 +0000 Subject: [PATCH] 1.0.37.21: :AUTO-CLOSE and better FD-STREAM-NAME for socket streams Fixed launchpad bug #540413. --- NEWS | 10 +++++++-- contrib/sb-bsd-sockets/inet.lisp | 10 +++++++++ contrib/sb-bsd-sockets/local.lisp | 6 ++++++ contrib/sb-bsd-sockets/sockets.lisp | 43 ++++++++++++++++++++++++++----------- version.lisp-expr | 2 +- 5 files changed, 55 insertions(+), 16 deletions(-) diff --git a/NEWS b/NEWS index 762cfe051..14cceff2f 100644 --- a/NEWS +++ b/NEWS @@ -1,11 +1,11 @@ ;;;; -*- coding: utf-8; fill-column: 78 -*- changes relative to sbcl-1.0.36: + * INCOMPATIBLE CHANGE: the SB-QUEUE contrib was merged into the + SB-CONCURRENCY contrib module. * new contrib: SB-CONCURRENCY is a new contrib; it's supposed to contain additional data structures and tools for concurrent programming; at the moment it contains a lock-free queue, and a lock-free mailbox implementation. - * deprecated contrib: the SB-QUEUE contrib was merged into the - SB-CONCURRENCY contrib and deprecated. * new feature: added SB-THREAD:TRY-SEMAPHORE, a non-blocking variant of SB-THREAD:WAIT-ON-SEMAPHORE. * new feature: SB-EXT:ATOMIC-DECF has been added as a companion to @@ -17,6 +17,12 @@ changes relative to sbcl-1.0.36: * enhancement: errors from NO-APPLICABLE-METHOD and NO-PRIMARY-METHOD now have a RETRY restart available to retry the generic function call. + * enhancement: SB-BSD-SOCKET improvements + ** sockets and socket streams now have a more informative printed + representation based on the corresponding SOCKET-NAME and + SOCKET-PEERNAME. + ** SOCKET-MAKE-STREAM once more supports the :AUTO-CLOSE option. + (lp#540413) * bug fix: correct restart text for the continuable error in MAKE-PACKAGE. * bug fix: a rare case of startup-time page table corruption. * bug fix: a semaphore with multiple waiters and some of them unwinding due diff --git a/contrib/sb-bsd-sockets/inet.lisp b/contrib/sb-bsd-sockets/inet.lisp index 57ab02c87..869b80f93 100644 --- a/contrib/sb-bsd-sockets/inet.lisp +++ b/contrib/sb-bsd-sockets/inet.lisp @@ -17,6 +17,16 @@ Examples: ;;; XXX should we *...* this? (defparameter inet-address-any (vector 0 0 0 0)) +(defmethod socket-namestring ((socket inet-socket)) + (ignore-errors + (multiple-value-bind (addr port) (socket-name socket) + (format nil "~{~A~^.~}:~A" (coerce addr 'list) port)))) + +(defmethod socket-peerstring ((socket inet-socket)) + (ignore-errors + (multiple-value-bind (addr port) (socket-peername socket) + (format nil "~{~A~^.~}:~A" (coerce addr 'list) port)))) + ;;; binding a socket to an address and port. Doubt that anyone's ;;; actually using this much, to be honest. diff --git a/contrib/sb-bsd-sockets/local.lisp b/contrib/sb-bsd-sockets/local.lisp index 8ca769bb3..1c9e9ae81 100644 --- a/contrib/sb-bsd-sockets/local.lisp +++ b/contrib/sb-bsd-sockets/local.lisp @@ -5,6 +5,12 @@ (:documentation "Class representing local domain (AF_LOCAL) sockets, also known as unix-domain sockets.")) +(defmethod socket-namestring ((socket local-socket)) + (ignore-errors (socket-name socket))) + +(defmethod socket-peerstring ((socket local-socket)) + (ignore-errors (socket-peername socket))) + (defmethod make-sockaddr-for ((socket local-socket) &optional sockaddr &rest address &aux (filename (first address))) (let ((sockaddr (or sockaddr (sockint::allocate-sockaddr-un)))) diff --git a/contrib/sb-bsd-sockets/sockets.lisp b/contrib/sb-bsd-sockets/sockets.lisp index ce6707ed3..9788cf2bc 100644 --- a/contrib/sb-bsd-sockets/sockets.lisp +++ b/contrib/sb-bsd-sockets/sockets.lisp @@ -25,9 +25,20 @@ directly instantiated."))) (defmethod print-object ((object socket) stream) (print-unreadable-object (object stream :type t :identity t) - (princ "descriptor " stream) - (princ (slot-value object 'file-descriptor) stream))) + (format stream "~@[~A, ~]~@[peer: ~A, ~]fd: ~A" + (socket-namestring object) + (socket-peerstring object) + (slot-value object 'file-descriptor)))) +(defgeneric socket-namestring (socket)) + +(defmethod socket-namestring (socket) + nil) + +(defgeneric socket-peerstring (socket)) + +(defmethod socket-peerstring (socket) + nil) (defmethod shared-initialize :after ((socket socket) slot-names &key protocol type @@ -362,28 +373,34 @@ for the stream.")) (element-type 'character) (buffering :full) (external-format :default) - timeout) - "Default method for SOCKET objects. An ELEMENT-TYPE of :DEFAULT -will construct a bivalent stream. Acceptable values for BUFFERING -are :FULL, :LINE and :NONE. Streams will have no TIMEOUT -by default. - The stream for SOCKET will be cached, and a second invocation of this -method will return the same stream. This may lead to oddities if this -function is invoked with inconsistent arguments \(e.g., one might request -an input stream and get an output stream in response\)." + timeout + auto-close) + "Default method for SOCKET objects. An ELEMENT-TYPE of :DEFAULT will +construct a bivalent stream. Acceptable values for BUFFERING are :FULL, :LINE +and :NONE. Streams will have no TIMEOUT by default. If AUTO-CLOSE is true, the +underlying OS socket is automatically closed after the stream and the socket +have been garbage collected. + +The stream for SOCKET will be cached, and a second invocation of this method +will return the same stream. This may lead to oddities if this function is +invoked with inconsistent arguments \(e.g., one might request an input stream +and get an output stream in response\)." (let ((stream (and (slot-boundp socket 'stream) (slot-value socket 'stream)))) (unless stream (setf stream (sb-sys:make-fd-stream (socket-file-descriptor socket) - :name "a socket" + :name (format nil "socket~@[ ~A~]~@[, peer: ~A~]" + (socket-namestring socket) + (socket-peerstring socket)) :dual-channel-p t :input input :output output :element-type element-type :buffering buffering :external-format external-format - :timeout timeout))) + :timeout timeout + :auto-close auto-close))) (setf (slot-value socket 'stream) stream) (sb-ext:cancel-finalization socket) stream)) diff --git a/version.lisp-expr b/version.lisp-expr index 8650cebf7..2893641f3 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.37.20" +"1.0.37.21" -- 2.11.4.GIT