1.0.40.7: socket-connect was not thread safe

https://bugs.launchpad.net/sbcl/+bug/505497

Committing diffs as supplied in the bug report after review and
testing.

Credits to Andrew Golding for the diffs and Jaap de Heer for the
initial report and reproducible test case.

diff --git a/contrib/sb-bsd-sockets/constants.lisp b/contrib/sb-bsd-sockets/constants.lisp
index 2b131f2..d967b4f 100644 (file)
--- a/contrib/sb-bsd-sockets/constants.lisp
+++ b/contrib/sb-bsd-sockets/constants.lisp
@@ -74,6 +74,7 @@
  (:integer EOPNOTSUPP "EOPNOTSUPP")
  (:integer EPERM "EPERM")
  (:integer EPROTONOSUPPORT "EPROTONOSUPPORT")
+ (:integer ERANGE "ERANGE")
  (:integer ESOCKTNOSUPPORT "ESOCKTNOSUPPORT")
  (:integer ENETUNREACH "ENETUNREACH")
  (:integer ENOTCONN "ENOTCONN")
@@ -123,8 +124,28 @@
                        (integer proto "int" "p_proto")))
  (:function getprotobyname ("getprotobyname" (* protoent)
                                              (name c-string)))
+
+;; getprotobyname_r is a thread-safe reentrant version of getprotobyname
+ (:function getprotobyname-r ("getprotobyname_r" int
+                                                 (name c-string)
+                                                 (result_buf (* protoent))
+                                                 (buffer (* char))
+                                                 (buffer-len size-t)
+                                                 #-solaris
+                                                 (result (* (* protoent)))))
+
+
  (:function getprotobynumber ("getprotobynumber" (* protoent)
                                                  (proto int)))
+ ;;ditto, save for the getprotobynumber part
+ (:function getprotobynumber-r ("getprotobynumber_r" int
+                                                 (proto int)
+                                                 (result_buf (* protoent))
+                                                 (buffer (* char))
+                                                 (buffer-len size-t)
+                                                 #-solaris
+                                                 (result (* (* protoent)))))
+
  (:integer inaddr-any "INADDR_ANY")
  (:structure in-addr ("struct in_addr"
                       ((array (unsigned 8)) addr "u_int32_t" "s_addr")))

diff --git a/contrib/sb-bsd-sockets/inet.lisp b/contrib/sb-bsd-sockets/inet.lisp
index 869b80f..1f2ef4c 100644 (file)
--- a/contrib/sb-bsd-sockets/inet.lisp
+++ b/contrib/sb-bsd-sockets/inet.lisp
@@ -67,14 +67,65 @@ Examples:
 ;;; getprotobyname only works in the internet domain, which is why this
 ;;; is here
 (defun get-protocol-by-name (name)      ;exported
-  "Returns the network protocol number associated with the string NAME,
-using getprotobyname(2) which typically looks in NIS or /etc/protocols"
-  ;; for extra brownie points, could return canonical protocol name
-  ;; and aliases as extra values
-  (let ((ent (sockint::getprotobyname name)))
-    (if (sb-alien::null-alien ent)
-        (error 'unknown-protocol :name name))
-    (sockint::protoent-proto ent)))
+  "Returns the values network protocol number associated with the string NAME,
+using getprotobyname(2) (or getprotobyname_r if SB-THREAD is enabled) which
+typically looks in NIS or /etc/protocols; the protocol's canonical name, and a
+list of protocol aliases"
+
+  ;;Brownie Points.  Hopefully there's one person out there using
+  ;;RSPF sockets and SBCL who will appreciate the extra info
+
+  (labels ((protoent-to-values (protoent)
+             (values
+              (sockint::protoent-proto protoent)
+              (sockint::protoent-name protoent)
+              (let ((index 0))
+                (loop
+                   for alias = (sb-alien:deref (sockint::protoent-aliases protoent) index)
+                   while (not (sb-alien:null-alien alias))
+                   do (incf index)
+                   collect (sb-alien::c-string-to-string (sb-alien:alien-sap alias)
+                                                         (sb-impl::default-external-format)
+                                                         'character))))))
+    #+sb-thread
+    (let ((buffer-length 1024)
+          (max-buffer 10000))
+      (declare (type fixnum buffer-length)
+               (type fixnum max-buffer))
+      (loop
+         (sb-alien:with-alien ((result-buf (* sockint::protoent)
+                                           (sb-alien:make-alien sockint::protoent))
+                               (buffer (* char )
+                                       (sb-alien:make-alien sb-alien:char buffer-length))
+                               #-solaris
+                               (result (* (* sockint::protoent))
+                                       (sb-alien:make-alien (* sockint::protoent))))
+
+           (let ((res (sockint::getprotobyname-r name
+                                                 result-buf
+                                                 buffer
+                                                 buffer-length
+                                                 #-solaris
+                                                 result)))
+             (if (eql res 0)
+                 (progn
+                   #-solaris
+                   (when (sb-alien::null-alien (sb-alien:deref result 0))
+                     (error 'unknown-protocol :name name))
+                   (return-from get-protocol-by-name
+                     (protoent-to-values result-buf)))
+                 (let ((errno (sb-unix::get-errno)))
+                   (if (eql errno  sockint::erange)
+                       (progn
+                         (incf buffer-length 1024)
+                         (if (> buffer-length max-buffer)
+                             (error "Exceeded max-buffer of ~d" max-buffer)))
+                       (error "Unexpected errno ~d" errno))))))))
+    #-sb-thread
+    (let ((ent (sockint::getprotobyname name)))
+      (if (sb-alien::null-alien ent)
+          (error 'unknown-protocol :name name))
+      (protoent-to-values ent))))
 
 ;;; our protocol provides make-sockaddr-for, size-of-sockaddr,
 ;;; bits-of-sockaddr

diff --git a/version.lisp-expr b/version.lisp-expr
index 70d10a2..548decf 100644 (file)
--- 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.40.6"
+"1.0.40.7"