X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-bsd-sockets%2Finet.lisp;h=e07f828aff4279c15e3713421eeba2c19fecc433;hb=b1f97e02b151845fd514e2fc254e69c1bd35ad48;hp=716095cf5794eb425dbcbc70576474a435e06273;hpb=a539be5d6c2ba4a6a68d761a6bcce977f9de2b19;p=sbcl.git

diff --git a/contrib/sb-bsd-sockets/inet.lisp b/contrib/sb-bsd-sockets/inet.lisp
index 716095c..e07f828 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.
 
@@ -25,7 +35,7 @@ Examples:
 \"127.0.0.1\". Signals an error if the string is malformed."
   (declare (type string dotted-quads))
   (labels ((oops ()
-             (error "~S is not a string designating an IP address." 
+             (error "~S is not a string designating an IP address."
                     dotted-quads))
            (check (x)
              (if (typep x '(unsigned-byte 8))
@@ -54,17 +64,78 @@ Examples:
              (format s "Protocol not found: ~a" (prin1-to-string
                                                  (unknown-protocol-name c))))))
 
+#+(and sb-thread (not os-provides-getprotoby-r))
+;; Since getprotobyname is not thread-safe, we need a lock.
+(sb-ext:defglobal **getprotoby-lock** (sb-thread:make-mutex :name "getprotoby lock"))
+
 ;;; 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)))
+  "Given a protocol name, return the protocol number, the protocol 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))))))
+    #+(and sb-thread os-provides-getprotoby-r)
+    (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))))))))
+    #-(and sb-thread os-provides-getprotoby-r)
+    (tagbody
+       (flet ((get-it ()
+                (let ((ent (sockint::getprotobyname name)))
+                  (if (sb-alien::null-alien ent)
+                      (go :error)
+                      (return-from get-protocol-by-name (protoent-to-values ent))))))
+         #+sb-thread
+         (sb-thread::with-system-mutex (**getprotoby-lock**)
+           (get-it))
+         #-sb-thread
+         (get-it))
+     :error
+       (error 'unknown-protocol :name name))))
 
 ;;; our protocol provides make-sockaddr-for, size-of-sockaddr,
 ;;; bits-of-sockaddr