strongly suspected problems, as of 0.8.3.10: please update this
bug instead of creating new ones
- gethostbyname, gethostbyaddr in sb-bsd-sockets
+ gethostbyaddr in sb-bsd-sockets
284: Thread safety: special variables
There are lots of special variables in SBCL, and I feel sure that at
;;;; -*- coding: utf-8; -*-
changes in sbcl-1.0.4 relative to sbcl-1.0.3:
+ * incompatible change: the thread-safe (on most platforms) getaddrinfo
+ and getnameinfo sockets functions are used instead of gethostbyaddr
+ and gethostbyname, on platforms where the newer functions are available.
+ As a result, the ALIASES field of HOST-ENT will always be NIL on these
+ platforms.
* bug fix: >= and <= gave wrong results when used with NaNs.
* bug fix: the #= and ## reader macros now interact reasonably with
funcallable instances.
;; some of these may be linux-specific
(:integer so-debug "SO_DEBUG"
- "Enable debugging in underlying protocol modules")
+ "Enable debugging in underlying protocol modules")
(:integer so-reuseaddr "SO_REUSEADDR" "Enable local address reuse")
- (:integer so-type "SO_TYPE") ;get only
- (:integer so-error "SO_ERROR") ;get only (also clears)
+ (:integer so-type "SO_TYPE") ;get only
+ (:integer so-error "SO_ERROR") ;get only (also clears)
(:integer so-dontroute "SO_DONTROUTE"
"Bypass routing facilities: instead send direct to appropriate network interface for the network portion of the destination address")
(:integer so-broadcast "SO_BROADCAST" "Request permission to send broadcast datagrams")
(:integer so-sndbuf "SO_SNDBUF")
-#+linux (:integer so-passcred "SO_PASSCRED")
+ #+linux (:integer so-passcred "SO_PASSCRED")
(:integer so-rcvbuf "SO_RCVBUF")
(:integer so-keepalive "SO_KEEPALIVE"
"Send periodic keepalives: if peer does not respond, we get SIGPIPE")
(:integer so-oobinline "SO_OOBINLINE"
"Put out-of-band data into the normal input queue when received")
(:integer so-no-check "SO_NO_CHECK")
-#+linux (:integer so-priority "SO_PRIORITY")
+ #+linux (:integer so-priority "SO_PRIORITY")
(:integer so-linger "SO_LINGER"
"For reliable streams, pause a while on closing when unsent messages are queued")
-#+linux (:integer so-bsdcompat "SO_BSDCOMPAT")
+ #+linux (:integer so-bsdcompat "SO_BSDCOMPAT")
(:integer so-sndlowat "SO_SNDLOWAT")
(:integer so-rcvlowat "SO_RCVLOWAT")
(:integer so-sndtimeo "SO_SNDTIMEO")
(:integer NO-RECOVERY "NO_RECOVERY" "Non recoverable errors, FORMERR, REFUSED, NOTIMP.")
(:integer NO-DATA "NO_DATA" "Valid name, no data record of requested type.")
(:integer NO-ADDRESS "NO_ADDRESS" "No address, look for MX record.")
+ (:function h-strerror ("hstrerror" c-string (errno int)))
(:integer O-NONBLOCK "O_NONBLOCK")
(:integer f-getfl "F_GETFL")
(:integer msg-dontroute "MSG_DONTROUTE")
(:integer msg-dontwait "MSG_DONTWAIT")
(:integer msg-nosignal "MSG_NOSIGNAL")
-#+linux (:integer msg-confirm "MSG_CONFIRM")
-#+linux (:integer msg-more "MSG_MORE")
+ #+linux (:integer msg-confirm "MSG_CONFIRM")
+ #+linux (:integer msg-more "MSG_MORE")
;; for socket-receive
(:type socklen-t "socklen_t")
(:type size-t "size_t")
(:type ssize-t "ssize_t")
- #|
+ #|
;;; stat is nothing to do with sockets, but I keep it around for testing
;;; the ffi glue
(:structure stat ("struct stat"
- (t dev "dev_t" "st_dev")
- ((alien:integer 32) atime "time_t" "st_atime")))
+ (t dev "dev_t" "st_dev")
+ ((alien:integer 32) atime "time_t" "st_atime")))
(:function stat ("stat" (integer 32)
- (file-name (* t))
+ (file-name (* t))
(buf (* t))))
|#
(:structure protoent ("struct protoent"
(addr (* t))
(len int)
(af int)))
-;;; should be using getaddrinfo instead?
+
+ ;; Re-entrant gethostbyname
+
+ #+linux
+ (:function gethostbyname-r ("gethostbyname_r"
+ int
+ (name c-string)
+ (ret (* hostent))
+ (buf (* char))
+ (buflen long)
+ (result (* (* hostent)))
+ (h-errnop (* int))))
+ ;; getaddrinfo / getnameinfo
+
+ #+sb-bsd-sockets-addrinfo
+ (:structure addrinfo ("struct addrinfo"
+ (integer flags "int" "ai_flags")
+ (integer family "int" "ai_family")
+ (integer socktype "int" "ai_socktype")
+ (integer protocol "int" "ai_protocol")
+ (integer addrlen "size_t""ai_addrlen")
+ ((* sockaddr-in) addr "struct sockaddr*" "ai_addr")
+ (c-string canonname "char *" "ai_canonname")
+ ((* t) next "struct addrinfo*" "ai_next")))
+
+ #+sb-bsd-sockets-addrinfo
+ (:function getaddrinfo ("getaddrinfo"
+ int
+ (node c-string)
+ (service c-string)
+ (hints (* addrinfo))
+ (res (* (* addrinfo)))))
+
+ #+sb-bsd-sockets-addrinfo
+ (:function freeaddrinfo ("freeaddrinfo"
+ void
+ (res (* addrinfo))))
+
+ #+sb-bsd-sockets-addrinfo
+ (:function gai-strerror ("gai_strerror"
+ c-string
+ (error-code int)))
+
+ #+sb-bsd-sockets-addrinfo
+ (:function getnameinfo ("getnameinfo"
+ int
+ (address (* sockaddr-in))
+ (address-length size-t)
+ (host (* char))
+ (host-len size-t)
+ (service (* char))
+ (service-len size-t)
+ (flags int)))
+
+ (:integer EAI-FAMILY "EAI_FAMILY")
+ (:integer EAI-SOCKTYPE "EAI_SOCKTYPE")
+ (:integer EAI-BADFLAGS "EAI_BADFLAGS")
+ (:integer EAI-NONAME "EAI_NONAME")
+ (:integer EAI-SERVICE "EAI_SERVICE")
+ (:integer EAI-ADDRFAMILY "EAI_ADDRFAMILY")
+ (:integer EAI-NODATA "EAI_NODATA")
+ (:integer EAI-MEMORY "EAI_MEMORY")
+ (:integer EAI-FAIL "EAI_FAIL")
+ (:integer EAI-AGAIN "EAI_AGAIN")
+ (:integer EAI-SYSTEM "EAI_SYSTEM")
+
+ (:integer NI-NAMEREQD "NI_NAMEREQD")
+
+ ;; Socket options
+
(:function setsockopt ("setsockopt" int
(socket int)
(level int)
(defpackage "SB-BSD-SOCKETS-INTERNAL"
(:nicknames "SOCKINT")
(:shadow close listen)
- #+cmu (:shadowing-import-from "CL" with-array-data)
- #+sbcl (:shadowing-import-from "SB-KERNEL" with-array-data)
- #+cmu (:use "COMMON-LISP" "ALIEN" "SYSTEM" "EXT" "C-CALL")
- #+sbcl (:use "COMMON-LISP" "SB-ALIEN" #+nil "SB-SYSTEM" "SB-EXT" "SB-C-CALL"))
-
-;;; SBCL changes a lot of package prefixes. To avoid littering the
-;;; code with conditionals, we use the SBCL package prefixes
-;;; throughout. This means that we need to create said packages
-;;; first, if we're using CMUCL
-
-;;; One thing that this exercise really has made clear is just how much
-;;; of the alien stuff is scattered around the cmucl package space
-;;; seemingly at random. Hmm.
-
-#+cmu
-(eval-when (:compile-toplevel :load-toplevel)
- (defun add-package-nickname (name nickname)
- (let ((p (find-package name)))
- (rename-package p (package-name p)
- (cons nickname (package-nicknames name)))))
- (add-package-nickname "EXT" "SB-EXT")
- (add-package-nickname "ALIEN" "SB-ALIEN")
- (add-package-nickname "UNIX" "SB-UNIX")
- (add-package-nickname "C-CALL" "SB-C-CALL")
- (add-package-nickname "KERNEL" "SB-KERNEL")
- (add-package-nickname "SYSTEM" "SB-SYS"))
+ (:shadowing-import-from "SB-KERNEL" with-array-data)
+ (:use "COMMON-LISP" "SB-ALIEN" "SB-EXT" "SB-C-CALL"))
(defpackage "SB-BSD-SOCKETS"
(:export socket local-socket inet-socket
host-ent-addresses host-ent-address
host-ent-aliases host-ent-name
name-service-error
+ getaddrinfo
;; not sure if these are really good names or not
netdb-internal-error
netdb-success-error
"
))
-#||
-
-<h2>Contents</h2>
-
-<ol>
-<li> General concepts
-<li> Methods applicable to all <a href="#socket">sockets</a>
-<li> <a href="#sockopt">Socket Options</a>
-<li> Methods applicable to a particular subclass
-<ol>
-<li> <a href="#internet">INET-SOCKET</a> - Internet Protocol (TCP, UDP, raw) sockets
-<li> Methods on <a href="#LOCAL-SOCKET">LOCAL-SOCKET</a> - Local-domain sockets
-</ol>
-<li> <a href="#name-service">Name resolution</a> (DNS, /etc/hosts, &c)
-</ol>
-
-<h2>General concepts</h2>
-
-<p>Most of the functions are modelled on the BSD socket API. BSD sockets
-are widely supported, portably <i>("portable" by Unix standards, at least)</i>
-available on a variety of systems, and documented. There are some
-differences in approach where we have taken advantage of some of the more useful features of Common Lisp - briefly
-
-<ul>
-<li> Where the C API would typically return -1 and set errno, we
-signal an error. All the errors are subclasses of SOCKET-CONDITION
-and generally correspond one for one with possible <tt>errno</tt> values
-
-<li> We use multiple return values in many places where the C API would use
-pass-by-reference values
-
-<li> We can often avoid supplying an explicit <i>length</i> argument to
-functions because we already know how long the argument is.
-
-<li> IP addresses and ports are represented in slightly friendlier fashion
-than "network-endian integers". See the section on <a href="#internet"
->Internet domain</a> sockets for details.
-</ul>
-
-
-|#
-
-(in-package :sb-bsd-sockets)
-
-(defmethod asdf:hyperdocumentation
- ((package (eql #.*package*)) symbol kind)
- (declare (ignore kind))
- (format nil "file://~A#~A"
- #.(namestring
- (merge-pathnames "index.html"
- (or *load-pathname* *compile-file-pathname*)))
- symbol))
+;;; gethostbyname/gethostbyaddr are generally not thread safe. POSIX
+;;; 1003.1-2003 defines an alternative API, which is specified in the
+;;; RFC to be thread-safe. If it seems to be available, use it.
+;;;
+;;; Unfortunately the manual page claims that these functions are not
+;;; thread-safe on OS X, but they probably can't be any worse than
+;;; gethostbyname and gethostbyaddr.
+(let ((addr (sb-alien::find-dynamic-foreign-symbol-address "getaddrinfo")))
+ (when addr
+ (pushnew :sb-bsd-sockets-addrinfo *features*)))
+++ /dev/null
-;;;; the old documentation extracted / generator for db-sockets / sb-bsd-sockets
-;;;;
-;;;; Not used anymore as the documentation is now integrated into the user manual,
-;;;; but I didn't have heart yet to delete this. -- NS 20040801
-
-(eval-when (:load-toplevel :compile-toplevel :execute)
- (defpackage :db-doc (:use :cl :asdf #+sbcl :sb-ext #+cmu :ext )))
-(in-package :db-doc)
-;;; turn water into wine ^W^W^W lisp into HTML
-
-#|
-OK. We need a design
-
-1) The aim is to document the current package, given a system.
-2) The assumption is that the system is loaded; this makes it easier to
-do cross-references and stuff
-3) We output HTML on *standard-output*
-4) Hyperlink wherever useful
-5) We're allowed to intern symbols all over the place if we like
-
-|#
-
-;;; note: break badly on multiple packages
-
-
-(defvar *symbols* nil
- "List of external symbols to print; derived from parsing DEFPACKAGE form")
-
-
-(defun worth-documenting-p (symbol)
- (and symbol
- (eql (symbol-package symbol) *package*)
- (or (ignore-errors (find-class symbol))
- (boundp symbol) (fboundp symbol))))
-
-(defun linkable-symbol-p (word)
- (labels ((symbol-char (c) (or (upper-case-p c) (digit-char-p c)
- (eql c #\-))))
- (and (every #'symbol-char word)
- (some #'upper-case-p word)
- (worth-documenting-p (find-symbol word)))))
-
-(defun markup-word (w)
- (if (symbolp w) (setf w (princ-to-string w)))
- (cond ((linkable-symbol-p w)
- (format nil "<a href=\"#~A\">~A</a>"
- w w))
- ((and (> (length w) 0)
- (eql (elt w 0) #\_)
- (eql (elt w (1- (length w))) #\_))
- (format nil "<b>~A</b>" (subseq w 1 (1- (length w)))))
- (t w)))
-(defun markup-space (w)
- (let ((para (search (coerce '(#\Newline #\Newline) 'string) w)))
- (if para
- (format nil "~A<P>~A"
- (subseq w 0 (1+ para))
- (markup-space (subseq w (1+ para) nil)))
- w)))
-
-(defun text-markup (text)
- (let ((start-word 0) (end-word 0))
- (labels ((read-word ()
- (setf end-word
- (position-if
- (lambda (x) (member x '(#\Space #\, #\. #\Newline)))
- text :start start-word))
- (subseq text start-word end-word))
- (read-space ()
- (setf start-word
- (position-if-not
- (lambda (x) (member x '(#\Space #\, #\. #\Newline)))
- text :start end-word ))
- (subseq text end-word start-word)))
- (with-output-to-string (o)
- (loop for inword = (read-word)
- do (princ (markup-word inword) o)
- while (and start-word end-word)
- do (princ (markup-space (read-space)) o)
- while (and start-word end-word))))))
-
-
-(defun do-defpackage (form stream)
- (setf *symbols* nil)
- (destructuring-bind (defn name &rest options) form
- (when (string-equal name (package-name *package*))
- (format stream "<h1>Package ~A</h1>~%" name)
- (when (documentation *package* t)
- (princ (text-markup (documentation *package* t))))
- (let ((exports (assoc :export options)))
- (when exports
- (setf *symbols* (mapcar #'symbol-name (cdr exports)))))
- 1)))
-
-(defun do-defclass (form stream)
- (destructuring-bind (defn name super slots &rest options) form
- (when (interesting-name-p name)
- (let ((class (find-class name)))
- (format stream "<p><a name=\"~A\"><i>Class: </i><b>~A</b></a>~%"
- name name)
- #+nil (format stream "<p><b>Superclasses: </b> ~{~A ~}~%"
- (mapcar (lambda (x) (text-markup (class-name x)))
- (mop:class-direct-superclasses class)))
- (if (documentation class 'type)
- (format stream "<blockquote>~A</blockquote>~%"
- (text-markup (documentation class 'type))))
- (when slots
- (princ "<p><b>Slots:</b><ul>" stream)
- (dolist (slot slots)
- (destructuring-bind
- (name &key reader writer accessor initarg initform type
- documentation)
- (if (consp slot) slot (list slot))
- (format stream "<li>~A : ~A</li>~%" name
- (if documentation (text-markup documentation) ""))))
- (princ "</ul>" stream))
- t))))
-
-
-(defun interesting-name-p (name)
- (cond ((consp name)
- (and (eql (car name) 'setf)
- (interesting-name-p (cadr name))))
- (t (member (symbol-name name) *symbols* :test #'string=))))
-
-(defun markup-lambdalist (l)
- (let (key-p)
- (loop for i in l
- if (eq '&key i) do (setf key-p t)
- end
- if (and (not key-p) (consp i))
- collect (list (car i) (markup-word (cadr i)))
- else collect i)))
-
-(defun do-defunlike (form label stream)
- (destructuring-bind (defn name lambdalist &optional doc &rest code) form
- (when (interesting-name-p name)
- (when (symbolp name)
- (setf *symbols* (remove (symbol-name name) *symbols* :test #'string=)))
- (format stream "<p><a name=\"~A\"><table width=\"100%\"><tr><td width=\"80%\">(~A <i>~A</i>)</td><td align=right>~A</td></tr></table>~%"
- name (string-downcase (princ-to-string name))
- (string-downcase
- (format nil "~{ ~A~}" (markup-lambdalist lambdalist)))
- label)
- (if (stringp doc)
- (format stream "<blockquote>~A</blockquote>~%"
- (text-markup doc)))
- t)))
-
-(defun do-defun (form stream) (do-defunlike form "Function" stream))
-(defun do-defmethod (form stream) (do-defunlike form "Method" stream))
-(defun do-defgeneric (form stream) (do-defunlike form "Generic Function" stream))
-(defun do-boolean-sockopt (form stream)
- (destructuring-bind (type lisp-name level c-name) form
- (pushnew (symbol-name lisp-name) *symbols*)
-
- (do-defunlike `(defun ,lisp-name ((socket socket) argument)
- ,(format nil "Return the value of the ~A socket option for SOCKET. This can also be updated with SETF." (symbol-name c-name) ) 'empty)
- "Accessor" stream)))
-
-(defun do-form (form output-stream)
- (cond ((not (listp form)) nil)
- ((string= (symbol-name (car form)) "DEFINE-SOCKET-OPTION-BOOL")
- (do-boolean-sockopt form output-stream))
- ((eq (car form) 'defclass)
- (do-defclass form output-stream))
- ((eq (car form) 'eval-when)
- (do-form (third form) output-stream))
- ((eq (car form) 'defpackage)
- (do-defpackage form output-stream))
- ((eq (car form) 'defun)
- (do-defun form output-stream))
- ((eq (car form) 'defmethod)
- (do-defmethod form output-stream))
- ((eq (car form) 'defgeneric)
- (do-defgeneric form output-stream))
- (t nil)))
-
-(defun do-file (input-stream output-stream)
- "Read in a Lisp program on INPUT-STREAM and make semi-pretty HTML on OUTPUT-STREAM"
- (let ((eof-marker (gensym)))
- (if (< 0
- (loop for form = (read input-stream nil eof-marker)
- until (eq form eof-marker)
- if (do-form form output-stream)
- count 1 #| and
- do (princ "<hr width=\"20%\">" output-stream) |# ))
- (format output-stream "<hr>"
- ))))
-
-(defvar *standard-sharpsign-reader*
- (get-dispatch-macro-character #\# #\|))
-
-(defun document-system (system &key
- (output-stream *standard-output*)
- (package *package*))
- "Produce HTML documentation for all files defined in SYSTEM, covering
-symbols exported from PACKAGE"
- (let ((*package* (find-package package))
- (*readtable* (copy-readtable))
- (*standard-output* output-stream))
- (set-dispatch-macro-character
- #\# #\|
- (lambda (s c n)
- (if (eql (peek-char nil s t nil t) #\|)
- (princ
- (text-markup
- (coerce
- (loop with discard = (read-char s t nil t)
- ;initially (princ "<P>")
- for c = (read-char s t nil t)
- until (and (eql c #\|)
- (eql (peek-char nil s t nil t) #\#))
- collect c
- finally (read-char s t nil t))
- 'string)))
- (funcall *standard-sharpsign-reader* s c n))))
- (dolist (c (cclan:all-components 'sb-bsd-sockets))
- (when (and (typep c 'cl-source-file)
- (not (typep c 'sb-bsd-sockets-system::constants-file)))
- (with-open-file (in (component-pathname c) :direction :input)
- (do-file in *standard-output*))))))
-
-(defun start ()
- (with-open-file (*standard-output* "index.html" :direction :output)
- (format t "<html><head><title>SBCL BSD-Sockets API Reference</title></head><body>~%")
- (format t
-"<!--
- This is a machine-generated file (from SB-BSD-SOCKETS source code, massaged
- by doc.lisp), so do not edit it directly.
- -->
-")
- (asdf:operate 'asdf:load-op 'sb-bsd-sockets)
- (document-system 'sb-bsd-sockets :package :sb-bsd-sockets)))
-
-(start)
(in-package :sb-bsd-sockets)
(defclass host-ent ()
- ((name :initarg :name :accessor host-ent-name)
+ ;; Unfortunately the docstring generator can't currently create.
+ ((name :initarg :name :accessor host-ent-name
+ :documentation "The name of the host")
+ ;; Deliberately not documented, since this isn't very useful,
+ ;; and the data isn't available when using getaddrinfo(). Unfortunately
+ ;; it is exported.
(aliases :initarg :aliases :accessor host-ent-aliases)
+ ;; presently always AF_INET. Not exported.
(address-type :initarg :type :accessor host-ent-address-type)
- ; presently always AF_INET
- (addresses :initarg :addresses :accessor host-ent-addresses))
- ;; FIXME: Our Texinfo documentation extracter need at least his to spit
- ;; out the signature. Real documentation would be better...
- (:documentation ""))
+ (addresses :initarg :addresses :accessor host-ent-addresses
+ :documentation "A list of addresses for this host."))
+ (:documentation "This class represents the results of an address lookup."))
(defgeneric host-ent-address (host-ent)
- ;; FIXME: Our Texinfo documentation extracter need at least his to spit
- ;; out the signature. Real documentation would be better...
- (:documentation ""))
+ (:documentation "Returns some valid address for HOST-ENT."))
(defmethod host-ent-address ((host-ent host-ent))
(car (host-ent-addresses host-ent)))
-;(define-condition host-not-found-error (socket-error)) ; host unknown
-;(define-condition no-address-error (socket-error)) ; valid name but no IP address
-;(define-condition no-recovery-error (socket-error)) ; name server error
-;(define-condition try-again-error (socket-error)) ; temporary
-
-(defun make-host-ent (h)
- (if (sb-alien:null-alien h) (name-service-error "gethostbyname"))
+(defun make-host-ent (h &optional errno)
+ (when (sb-grovel::foreign-nullp h)
+ (name-service-error "gethostbyname" errno))
(let* ((length (sockint::hostent-length h))
(aliases (loop for i = 0 then (1+ i)
for al = (sb-alien:deref (sockint::hostent-aliases h) i)
collect (ecase (sockint::hostent-type h)
(#.sockint::af-inet
(assert (= length 4))
- (let ((addr (make-array 4 :element-type '(unsigned-byte 8))))
- (loop for i from 0 below length
- do (setf (elt addr i) (sb-alien:deref ad i)))
- addr))
+ (naturalize-unsigned-byte-8-array ad length))
#-win32
(#.sockint::af-local
(sb-alien:cast ad sb-alien:c-string))))))
:aliases aliases
:addresses addresses)))
+(defun naturalize-unsigned-byte-8-array (array length)
+ (let ((addr (make-array 4 :element-type '(unsigned-byte 8))))
+ (dotimes (i length)
+ (setf (elt addr i) (sb-alien:deref array i)))
+ addr))
+
+;;; Resolving
+
(defun get-host-by-name (host-name)
- "Returns a HOST-ENT instance for HOST-NAME or throws some kind of condition.
+ "Returns a HOST-ENT instance for HOST-NAME or signals a NAME-SERVICE-ERROR.
HOST-NAME may also be an IP address in dotted quad notation or some other
-weird stuff - see gethostbyname(3) for grisly details."
+weird stuff - see gethostbyname(3) or getaddrinfo(3) for the details."
+ #+sb-bsd-sockets-addrinfo
+ (get-address-info host-name)
+ #-sb-bsd-sockets-addrinfo
(make-host-ent (sockint::gethostbyname host-name)))
(defun get-host-by-address (address)
"Returns a HOST-ENT instance for ADDRESS, which should be a vector of
- (integer 0 255), or throws some kind of error. See gethostbyaddr(3) for
-grisly details."
+ (integer 0 255), or signals a NAME-SERVICE-ERROR. See gethostbyaddr(3)
+ or gethostinfo(3) for details."
+ #+sb-bsd-sockets-addrinfo
+ (get-name-info address)
+ #-sb-bsd-sockets-addrinfo
(sockint::with-in-addr packed-addr ()
(let ((addr-vector (coerce address 'vector)))
(loop for i from 0 below (length addr-vector)
4
sockint::af-inet)))))
-;;; The remainder is my fault - gw
+;;; Emulate the above two functions with getaddrinfo / getnameinfo
+
+#+sb-bsd-sockets-addrinfo
+(defun get-address-info (node)
+ (sb-alien:with-alien ((res (* (* sockint::addrinfo)) :local
+ (sb-alien:make-alien (* sockint::addrinfo))))
+ (let ((err (sockint::getaddrinfo node nil nil res)))
+ (if (zerop err)
+ (let ((host-ent (make-instance 'host-ent
+ :name node
+ :type sockint::af-inet
+ :aliases nil
+ :addresses nil)))
+ (loop for sap = (sb-alien:deref res) then (sockint::addrinfo-next info)
+ until (sb-alien::null-alien sap)
+ for info = (sb-alien:cast sap (* sockint::addrinfo))
+ ;; Only handle AF_INET currently.
+ do (when (eq (sockint::addrinfo-family info) sockint::af-inet)
+ (let* ((sockaddr (sockint::addrinfo-addr info))
+ (address (sockint::sockaddr-in-addr sockaddr)))
+ ;; The same effective result can be multiple time
+ ;; in the list, with different socktypes. Only record
+ ;; each address once.
+ (setf (host-ent-addresses host-ent)
+ (adjoin (naturalize-unsigned-byte-8-array address
+ 4)
+ (host-ent-addresses host-ent)
+ :test 'equalp)))))
+ (sockint::free-addrinfo (sb-alien:deref res))
+ host-ent)
+ (addrinfo-error "getaddrinfo" err)))))
+
+(defconstant ni-max-host 1025)
+
+#+sb-bsd-sockets-addrinfo
+(defun get-name-info (address)
+ (assert (= (length address) 4))
+ (sockint::with-sockaddr-in sockaddr ()
+ (sb-alien:with-alien ((host-buf (array char #.ni-max-host)))
+ (setf (sockint::sockaddr-in-family sockaddr) sockint::af-inet)
+ (dotimes (i 4)
+ (setf (sb-alien:deref (sockint::sockaddr-in-addr sockaddr) i)
+ (aref address i)))
+ (let ((err (sockint::getnameinfo (sb-alien:alien-sap sockaddr)
+ (sb-alien:alien-size sockint::sockaddr-in :bytes)
+ (sb-alien:cast host-buf (* char)) ni-max-host
+ nil 0
+ sockint::ni-namereqd)))
+ (if (zerop err)
+ (make-instance 'host-ent
+ :name (sb-alien::c-string-to-string
+ (sb-alien:alien-sap host-buf)
+ (sb-impl::default-external-format)
+ 'character)
+ :type sockint::af-inet
+ :aliases nil
+ :addresses (list address))
+ (addrinfo-error "getnameinfo" err))))))
+
+;;; Error handling
(defvar *name-service-errno* 0
"The value of h_errno, after it's been fetched from Unix-land by calling
GET-NAME-SERVICE-ERRNO")
-(defun name-service-error (where)
- ;; FIXME: Our Texinfo documentation extracter need at least his to spit
- ;; out the signature. Real documentation would be better...
- ""
- (get-name-service-errno)
- ;; Comment next to NETDB_INTERNAL in netdb.h says "See errno.".
- ;; This special case treatment hasn't actually been tested yet.
- #-win32
- (if (= *name-service-errno* sockint::NETDB-INTERNAL)
- (socket-error where)
- (let ((condition
- (condition-for-name-service-errno *name-service-errno*)))
- (error condition :errno *name-service-errno* :syscall where))))
+(defun name-service-error (where &optional errno)
+ ;; There was a dummy docstring here for the texinfo extractor, but I
+ ;; see no reason for this to be documented in the manual, and removed
+ ;; it. -- JES
+ (let ((*name-service-errno* (get-name-service-errno errno)))
+ ;; Comment next to NETDB_INTERNAL in netdb.h says "See errno.".
+ ;; This special case treatment hasn't actually been tested yet.
+ #-win32
+ (if (= *name-service-errno* sockint::NETDB-INTERNAL)
+ (socket-error where)
+ (let ((condition
+ (condition-for-name-service-errno *name-service-errno*)))
+ (error condition :errno *name-service-errno* :syscall where)))))
+
+(defun addrinfo-error (where error-code)
+ (let ((condition (condition-for-name-service-error-code error-code)))
+ (error condition :error-code error-code :syscall where)))
(define-condition name-service-error (condition)
- ((errno :initform nil
- :initarg :errno
- :reader name-service-error-errno)
+ ((errno :initform nil :initarg :errno :reader name-service-error-errno)
+ (error-code :initform nil :initarg :error-code
+ :reader name-service-error-error-code)
(symbol :initform nil :initarg :symbol :reader name-service-error-symbol)
(syscall :initform "an unknown location" :initarg :syscall :reader name-service-error-syscall))
(:report (lambda (c s)
- (let ((num (name-service-error-errno c)))
+ (let* ((errno (name-service-error-errno c))
+ (error-code (name-service-error-error-code c)))
(format s "Name service error in \"~A\": ~A (~A)"
(name-service-error-syscall c)
(or (name-service-error-symbol c)
- (name-service-error-errno c))
- (get-name-service-error-message num))))))
+ errno
+ error-code)
+ (get-name-service-error-message errno error-code))))))
-(defmacro define-name-service-condition (symbol name)
+(defparameter *conditions-for-name-service-errno* nil)
+;; getaddrinfo and getnameinfo return an error code, rather than using
+;; h_errno. While on Linux there's no overlap between their possible
+;; values, this doesn't seem to be guaranteed on all systems.
+(defparameter *conditions-for-name-service-error-code* nil)
+
+;; Define a special name-service-error for variour error cases, and associate
+;; them with the matching h_errno / error code.
+(defmacro define-name-service-condition (errno-symbol error-code-symbol name)
`(progn
(define-condition ,name (name-service-error)
- ((symbol :reader name-service-error-symbol :initform (quote ,symbol))))
- (push (cons ,symbol (quote ,name)) *conditions-for-name-service-errno*)))
-
-(defparameter *conditions-for-name-service-errno* nil)
+ ((errno-symbol :reader name-service-error-errno-symbol
+ :initform (quote ,errno-symbol))
+ (error-code-symbol :reader name-service-error-error-code-symbol
+ :initform (quote ,error-code-symbol))))
+ (push (cons ,errno-symbol (quote ,name))
+ *conditions-for-name-service-errno*)
+ #+sb-bsd-sockets-addrinfo
+ (push (cons ,error-code-symbol (quote ,name))
+ *conditions-for-name-service-error-code*)))
#-win32
-(define-name-service-condition sockint::NETDB-INTERNAL netdb-internal-error)
+(define-name-service-condition
+ sockint::NETDB-INTERNAL
+ nil ;; Doesn't map directly to any getaddrinfo error code
+ netdb-internal-error)
#-win32
-(define-name-service-condition sockint::NETDB-SUCCESS netdb-success-error)
-(define-name-service-condition sockint::HOST-NOT-FOUND host-not-found-error)
-(define-name-service-condition sockint::TRY-AGAIN try-again-error)
-(define-name-service-condition sockint::NO-RECOVERY no-recovery-error)
-;; this is the same as the next one
-;;(define-name-service-condition sockint::NO-DATA no-data-error)
-(define-name-service-condition sockint::NO-ADDRESS no-address-error)
+(define-name-service-condition
+ sockint::NETDB-SUCCESS
+ nil ;; Doesn't map directly to any getaddrinfo error code
+ netdb-success-error)
+(define-name-service-condition
+ sockint::HOST-NOT-FOUND
+ sockint::EAI-NONAME
+ host-not-found-error)
+(define-name-service-condition
+ sockint::TRY-AGAIN
+ sockint::EAI-AGAIN
+ try-again-error)
+(define-name-service-condition
+ sockint::NO-RECOVERY
+ sockint::EAI-FAIL
+ no-recovery-error)
+(define-name-service-condition
+ sockint::NO-ADDRESS ;; Also defined as NO-DATA, with the same value
+ sockint::EAI-NODATA
+ no-address-error)
(defun condition-for-name-service-errno (err)
(or (cdr (assoc err *conditions-for-name-service-errno* :test #'eql))
- 'name-service))
+ 'name-service-error))
-(defun get-name-service-errno ()
+(defun condition-for-name-service-error-code (err)
+ (or (cdr (assoc err *conditions-for-name-service-error-code* :test #'eql))
+ 'name-service-error))
+
+(defun get-name-service-errno (&optional errno)
(setf *name-service-errno*
- (sb-alien:alien-funcall
- #-win32
- (sb-alien:extern-alien "get_h_errno" (function integer))
- #+win32
- (sb-alien:extern-alien "WSAGetLastError" (function integer)))))
-
-#-(and cmu solaris)
-(progn
- #+(and sbcl (not win32))
- (sb-alien:define-alien-routine "hstrerror"
- sb-c-call:c-string
- (errno integer))
- #+cmu
- (alien:def-alien-routine "hstrerror"
- sb-c-call:c-string
- (errno integer))
- (defun get-name-service-error-message (num)
- (hstrerror num))
-)
-
-;;; placeholder for hstrerror on windows
-#+(and sbcl win32)
-(defun hstrerror () 0)
+ (or errno
+ (sb-alien:alien-funcall
+ #-win32
+ (sb-alien:extern-alien "get_h_errno" (function integer))
+ #+win32
+ (sb-alien:extern-alien "WSAGetLastError" (function integer))))))
+
+(defun get-name-service-error-message (errno error-code)
+ #-win32
+ (if errno
+ (sockint::h-strerror errno)
+ (sockint::gai-strerror error-code)))
@node Name Service
@section Name Service
-Presently name service is implemented by calling whatever
-@code{gethostbyname(2)} uses. This may be any or all of
-@file{/etc/hosts}, NIS, DNS, or something completely different.
-Typically it's controlled by @file{/etc/nsswitch.conf}.
-
-Direct links to the asynchronous @code{resolver(3)} routines would be
-nice to have eventually, so that we can do DNS lookups in parallel
-with other things
+Presently name service is implemented by calling out to the
+@code{getaddrinfo(3)} and @code{gethostinfo(3)}, or to
+@code{gethostbyname(3)} @code{gethostbyaddr(3)} on platforms where
+the preferred functions are not available. The exact details of
+the name resolving process (for example the choice of whether
+DNS or a hosts file is used for lookup) are platform dependent.
+
+@c Direct links to the asynchronous @code{resolver(3)} routines would be
+@c nice to have eventually, so that we can do DNS lookups in parallel
+@c with other things.
@include class-sb-bsd-sockets-host-ent.texinfo
@include fun-sb-bsd-sockets-get-host-by-address.texinfo
@include fun-sb-bsd-sockets-host-ent-address.texinfo
-
-@include fun-sb-bsd-sockets-name-service-error.texinfo
;;; 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.3.5"
+"1.0.3.6"
projects / sbcl.git / commitdiff