source: trunk/source/level-1/l1-sockets.lisp @ 13334

Last change on this file since 13334 was 13067, checked in by rme, 10 years ago

Update copyright notices.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 54.6 KB
RevLine 
[6]1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
[13067]3;;;   Copyright (C) 2001-2009 Clozure Associates
[13066]4;;;   This file is part of Clozure CL. 
[6]5;;;
[13066]6;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with Clozure CL as the
[6]8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
[13066]9;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
[6]10;;;   conflict, the preamble takes precedence. 
11;;;
[13066]12;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
[6]13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CCL")
18
[1539]19
20
21;;; basic socket API
[6]22(eval-when (:compile-toplevel :load-toplevel :execute)
23  (export '(MAKE-SOCKET
24            ACCEPT-CONNECTION
25            DOTTED-TO-IPADDR
26            IPADDR-TO-DOTTED
27            IPADDR-TO-HOSTNAME
28            LOOKUP-HOSTNAME
29            LOOKUP-PORT
30            ;;with-pending-connect
31            RECEIVE-FROM
32            SEND-TO
33            SHUTDOWN
34            ;;socket-control
35            SOCKET-OS-FD
36            REMOTE-HOST
37            REMOTE-PORT
38            REMOTE-FILENAME
39            LOCAL-HOST
40            LOCAL-PORT
41            LOCAL-FILENAME
42            SOCKET-ADDRESS-FAMILY
43            SOCKET-CONNECT
44            SOCKET-FORMAT
45            SOCKET-TYPE
46            SOCKET-ERROR
47            SOCKET-ERROR-CODE
48            SOCKET-ERROR-IDENTIFIER
49            SOCKET-ERROR-SITUATION
[10574]50            WITH-OPEN-SOCKET))
51  #+windows-target
52  (defmacro check-winsock-error (form)
53    (let* ((val (gensym)))
54      `(let* ((,val ,form))
55        (if (< ,val 0)
56          (%get-winsock-error)
57          ,val))))
58  (defmacro check-socket-error (form)
59    #+windows-target `(check-winsock-error ,form)
60    #-windows-target `(int-errno-call ,form))
61  )
[6]62
[10574]63
64#+windows-target
65(defun %get-winsock-error ()
66  (- (#_WSAGetLastError)))
67
[1539]68;;; The PPC is big-endian (uses network byte order), which makes
69;;; things like #_htonl and #_htonl no-ops.  These functions aren't
70;;; necessarily defined as functions in some header files (I'm sure
71;;; that that either complies with or violates some C standard), and
72;;; it doesn't seem to make much sense to fight that to do ff-calls
73;;; to a couple of identity functions.
74
[3978]75#+big-endian-target
[1539]76(progn
77  (defmacro HTONL (x) x)
78  (defmacro HTONS (x) x)
79  (defmacro NTOHL (x) x)
80  (defmacro NTOHS (x) x))
[3978]81
82#+little-endian-target
83(progn
84  (declaim (inline %bswap32 %bswap16))
85  (defun %bswap32 (x)
86    (declare (type (unsigned-byte 32) x))
[5305]87    (%swap-u32 x))
[3978]88  (defun %bswap16 (x)
[5225]89    (declare (type (unsigned-byte 16) x))
[5305]90    (%swap-u16 x))
[3978]91  (defmacro HTONL (x) `(%bswap32 ,x))
92  (defmacro HTONS (x) `(%bswap16 ,x))
93  (defmacro NTOHL (x) `(%bswap32 ,x))
94  (defmacro NTOHS (x) `(%bswap16 ,x)))
95
[5417]96(defparameter *default-socket-character-encoding*
97  nil)
[3978]98
[5417]99(defmethod default-character-encoding ((domain (eql :socket)))
100  *default-socket-character-encoding*)
[1539]101 
102
103;;; On some (hypothetical) little-endian platform, we might want to
104;;; define HTONL and HTONS to actually swap bytes around.
105
[6]106(defpackage "OPENMCL-SOCKET"
107  (:use "CL")
108  (:import-from "CCL"
109                "MAKE-SOCKET"
110                "ACCEPT-CONNECTION"
111                "DOTTED-TO-IPADDR"
112                "IPADDR-TO-DOTTED"
113                "IPADDR-TO-HOSTNAME"
114                "LOOKUP-HOSTNAME"
115                "LOOKUP-PORT"
116                ;;with-pending-connect
117                "RECEIVE-FROM"
118                "SEND-TO"
119                "SHUTDOWN"
120                ;;socket-control
121                "SOCKET-OS-FD"
122                "REMOTE-HOST"
123                "REMOTE-PORT"
124                "REMOTE-FILENAME"
125                "LOCAL-HOST"
126                "LOCAL-PORT"
127                "LOCAL-FILENAME"
128                "SOCKET-ADDRESS-FAMILY"
129                "SOCKET-CONNECT"
130                "SOCKET-FORMAT"
131                "SOCKET-TYPE"
132                "SOCKET-ERROR"
133                "SOCKET-ERROR-CODE"
134                "SOCKET-ERROR-IDENTIFIER"
135                "SOCKET-ERROR-SITUATION"
136                "WITH-OPEN-SOCKET")
137  (:export  "MAKE-SOCKET"
138            "ACCEPT-CONNECTION"
139            "DOTTED-TO-IPADDR"
140            "IPADDR-TO-DOTTED"
141            "IPADDR-TO-HOSTNAME"
142            "LOOKUP-HOSTNAME"
143            "LOOKUP-PORT"
144            ;;with-pending-connect
145            "RECEIVE-FROM"
146            "SEND-TO"
147            "SHUTDOWN"
148            ;;socket-control
149            "SOCKET-OS-FD"
150            "REMOTE-HOST"
151            "REMOTE-PORT"
152            "REMOTE-FILENAME"
153            "LOCAL-HOST"
154            "LOCAL-PORT"
155            "LOCAL-FILENAME"
156            "SOCKET-ADDRESS-FAMILY"
157            "SOCKET-CONNECT"
158            "SOCKET-FORMAT"
159            "SOCKET-TYPE"
160            "SOCKET-ERROR"
161            "SOCKET-ERROR-CODE"
162            "SOCKET-ERROR-IDENTIFIER"
163            "SOCKET-ERROR-SITUATION"
164            "WITH-OPEN-SOCKET"))
165
166
[10544]167
[423]168(define-condition socket-error (simple-stream-error)
[6]169  ((code :initarg :code :reader socket-error-code)
170   (identifier :initform :unknown :initarg :identifier :reader socket-error-identifier)
[768]171   (Situation :initarg :situation :reader socket-error-situation)))
[6]172
[768]173(define-condition socket-creation-error (simple-error)
174  ((code :initarg :code :reader socket-creation-error-code)
[7624]175   (identifier :initform :unknown :initarg :identifier :reader socket-creation-error-identifier)
[768]176   (situation :initarg :situation :reader socket-creation-error-situation)))
177
[6]178(defvar *socket-error-identifiers*
[10685]179  #-windows-target
[6]180  (list #$EADDRINUSE :address-in-use
181        #$ECONNABORTED :connection-aborted
182        #$ENOBUFS :no-buffer-space
183        #$ENOMEM :no-buffer-space
184        #$ENFILE :no-buffer-space
185        #$ETIMEDOUT :connection-timed-out
186        #$ECONNREFUSED :connection-refused
187        #$ENETUNREACH :host-unreachable
188        #$EHOSTUNREACH :host-unreachable
189        #$EHOSTDOWN :host-down
190        #$ENETDOWN :network-down
[423]191        #$EADDRNOTAVAIL :address-not-available
192        #$ENETRESET :network-reset
193        #$ECONNRESET :connection-reset
194        #$ESHUTDOWN :shutdown
[6]195        #$EACCES :access-denied
[10685]196        #$EPERM :access-denied)
197  #+windows-target
198  (list #$WSAEADDRINUSE :address-in-use
199        #$WSAECONNABORTED :connection-aborted
200        #$WSAENOBUFS :no-buffer-space
201        #$ENOMEM :no-buffer-space
202        #$ENFILE :no-buffer-space
203        #$WSAETIMEDOUT :connection-timed-out
204        #$WSAECONNREFUSED :connection-refused
205        #$WSAENETUNREACH :host-unreachable
206        #$WSAEHOSTUNREACH :host-unreachable
207        #$WSAEHOSTDOWN :host-down
208        #$WSAENETDOWN :network-down
209        #$WSAEADDRNOTAVAIL :address-not-available
210        #$WSAENETRESET :network-reset
211        #$WSAECONNRESET :connection-reset
212        #$WSAESHUTDOWN :shutdown
213        #$EACCES :access-denied
214        #$EPERM :access-denied)
215  )
[6]216
217
218(declaim (inline socket-call))
[423]219(defun socket-call (stream where res)
[6]220  (if (< res 0)
[423]221    (socket-error stream where res)
[6]222    res))
223
[10685]224#-windows-target
[10865]225(defun %gai-strerror (errno)
226  (let* ((err (abs errno))
227         (p (#_gai_strerror err)))
228    (if (%null-ptr-p p)
229      (format nil "Unknown nameserver error ~d" err)
230      (%get-cstring p))))
[6]231   
[423]232
233
234(defun socket-error (stream where errno &optional nameserver-p)
[768]235  "Creates and signals (via error) one of two socket error
236conditions, based on the state of the arguments."
[10698]237  #+windows-target (declare (ignore nameserver-p))
[6]238  (when (< errno 0)
239    (setq errno (- errno)))
[423]240  (if stream
241    (error (make-condition 'socket-error
242                           :stream stream
243                           :code errno
244                           :identifier (getf *socket-error-identifiers* errno :unknown)
245                           :situation where
246                           ;; TODO: this is a constant arg, there is a way to put this
247                           ;; in the class definition, just need to remember how...
[7978]248                           :format-control "~a (error #~d) during ~a"
[423]249                           :format-arguments (list
[10698]250                                              #+windows-target
251                                              (%windows-error-string errno)
252                                              #-windows-target
[423]253                                              (if nameserver-p
[10865]254                                                (%gai-strerror errno)
[423]255                                                (%strerror errno))
[7978]256                                              errno where)))
[768]257    (error (make-condition 'socket-creation-error
258                           :code errno
259                           :identifier (getf *socket-error-identifiers* errno :unknown)
260                           :situation where
261                           ;; TODO: this is a constant arg, there is a way to put this
262                           ;; in the class definition, just need to remember how...
[10865]263                           :format-control "~a (error #~d) during socket creation or nameserver operation in ~a"
[768]264                           :format-arguments (list
[10698]265                                              #+windows-target
266                                              (%windows-error-string errno)
267                                              #-windows-target
[768]268                                              (if nameserver-p
[10865]269                                                (%gai-strerror errno)
[768]270                                                (%strerror errno))
[7978]271                                              errno where)))))
[423]272   
[6]273
[423]274
[7978]275;; If true, this will try to allow other cooperative processes to run
276;; while socket io is happening.  Since CCL threads are preemptively
277;; scheduled, this isn't particularly meaningful.
278(defvar *multiprocessing-socket-io* nil)
[6]279
280(defclass socket ()
281  ())
282
283(defmacro with-open-socket ((var . args) &body body
284                            &aux (socket (make-symbol "socket"))
285                                 (done (make-symbol "done")))
[2439]286  "Execute body with var bound to the result of applying make-socket to
287make-socket-args. The socket gets closed on exit."
[6]288  `(let (,socket ,done)
289     (unwind-protect
290         (multiple-value-prog1
291           (let ((,var (setq ,socket (make-socket ,@args))))
292             ,@body)
293           (setq ,done t))
294       (when ,socket (close ,socket :abort (not ,done))))))
295
[2439]296(defgeneric socket-address-family (socket)
297  (:documentation "Return :internet or :file, as appropriate."))
298
[6]299(defclass ip-socket (socket)
300  ())
301
[2439]302(defmethod socket-address-family ((socket ip-socket)) :internet)
[6]303
304(defclass file-socket (socket)
305  ())
306
[2439]307(defmethod socket-address-family ((socket file-socket)) :file)
[6]308
309(defclass tcp-socket (ip-socket)
310  ())
311
[2439]312(defgeneric socket-type (socket)
313  (:documentation
314   "Return :stream for tcp-stream and listener-socket, and :datagram
315for udp-socket."))
[6]316
[2439]317(defmethod socket-type ((socket tcp-socket)) :stream)
318
[6]319(defclass stream-file-socket (file-socket)
320  ())
321
[2439]322(defmethod socket-type ((socket stream-file-socket)) :stream)
[6]323
324
[4900]325;;; An active TCP socket is an honest-to-goodness stream.
[5305]326(defclass tcp-stream (tcp-socket)
[6]327  ())
328
[5305]329(defclass fundamental-tcp-stream (tcp-stream
330                                  fd-stream
331                                  buffered-binary-io-stream-mixin
332                                  buffered-character-io-stream-mixin)
333    ())
334
335(make-built-in-class 'basic-tcp-stream
336                     'tcp-stream
337                     'basic-binary-io-stream
338                     'basic-character-io-stream)
339
[2439]340(defgeneric socket-connect (stream)
[5305]341 (:documentation
[2439]342   "Return :active for tcp-stream, :passive for listener-socket, and NIL
343for udp-socket"))
[6]344
[2439]345(defmethod socket-connect ((stream tcp-stream)) :active)
346
347(defgeneric socket-format (stream)
348  (:documentation
349   "Return the socket format as specified by the :format argument to
350make-socket."))
351
352(defmethod socket-format ((stream tcp-stream))
[6]353  (if (eq (stream-element-type stream) 'character)
354    :text
355    ;; Should distinguish between :binary and :bivalent, but hardly
356    ;; seems worth carrying around an extra slot just for that.
357    :bivalent))
358
359(defmethod socket-device ((stream tcp-stream))
[4900]360  (let ((ioblock (stream-ioblock stream nil)))
[6]361    (and ioblock (ioblock-device ioblock))))
362
363(defmethod select-stream-class ((class tcp-stream) in-p out-p char-p)
364  (declare (ignore char-p)) ; TODO: is there any real reason to care about this?
[4917]365  ;; Yes, in general.  There is.
[6]366  (assert (and in-p out-p) () "Non-bidirectional tcp stream?")
[5305]367  'fundamental-tcp-stream)
[6]368
[5305]369(defmethod map-to-basic-stream-class-name ((name (eql 'tcp-stream)))
370  'basic-tcp-stream)
371
372(defmethod select-stream-class ((s (eql 'basic-tcp-stream)) in-p out-p char-p)
373  (declare (ignore char-p))
374  (assert (and in-p out-p) () "Non-bidirectional tcp stream?")
375  'basic-tcp-stream)
376
[4333]377;;; A FILE-SOCKET-STREAM is also honest. To goodness.
[5305]378(defclass file-socket-stream (stream-file-socket)
[6]379  ())
380
[5305]381(defclass fundamental-file-socket-stream (file-socket-stream
382                                          fd-stream
383                                          buffered-binary-io-stream-mixin
384                                          buffered-character-io-stream-mixin)
385    ())
386
387(make-built-in-class 'basic-file-socket-stream
388                     'file-socket-stream
389                     'basic-binary-io-stream
390                     'basic-character-io-stream)
391
392
[5559]393(defmethod map-to-basic-stream-class-name ((name (eql 'file-socket-stream)))
394  'basic-file-socket-stream)
[5305]395
[6]396(defmethod select-stream-class ((class file-socket-stream) in-p out-p char-p)
397  (declare (ignore char-p)) ; TODO: is there any real reason to care about this?
[5559]398  (assert (and in-p out-p) () "Non-bidirectional file-socket stream?")
[5305]399  'fundamental-file-socket-stream)
[6]400
[5559]401(defmethod select-stream-class ((s (eql 'basic-file-socket-stream)) in-p out-p char-p)
402  (declare (ignore char-p))
403  (assert (and in-p out-p) () "Non-bidirectional file-socket stream?")
404  'basic-file-socket-stream)
405
[6]406(defclass unconnected-socket (socket)
407  ((device :initarg :device :accessor socket-device)
408   (keys :initarg :keys :reader socket-keys)))
409
[2439]410(defmethod socket-format ((socket unconnected-socket))
[6]411  (or (getf (socket-keys socket) :format) :text))
412
[2439]413(defgeneric close (socket &key abort)
414  (:documentation
415   "The close generic function can be applied to sockets. It releases the
416operating system resources associated with the socket."))
417
418(defmethod close ((socket unconnected-socket) &key abort)
[6]419  (declare (ignore abort))
420  (when (socket-device socket)
421    (fd-close (socket-device socket))
[384]422    (setf (socket-device socket) nil)
423    t))
[6]424
425;; A passive tcp socket just generates connection streams
426(defclass listener-socket (tcp-socket unconnected-socket) ())
427
428(defmethod SOCKET-CONNECT ((stream listener-socket)) :passive)
429
430(defclass file-listener-socket (stream-file-socket unconnected-socket) ())
431
432(defmethod SOCKET-CONNECT ((stream file-listener-socket)) :passive)
433
434;;; A FILE-LISTENER-SOCKET should try to delete the filesystem
435;;; entity when closing.
436
[10865]437#-windows-target
[6]438(defmethod close :before ((s file-listener-socket) &key abort)
439  (declare (ignore abort))
[440]440  (let* ((path (local-socket-filename (socket-device s) s)))
[6]441    (when path (%delete-file path))))
442
443
444;; A udp socket just sends and receives packets.
445(defclass udp-socket (ip-socket unconnected-socket) ())
446
[2439]447(defmethod socket-type ((stream udp-socket)) :datagram)
448(defmethod socket-connect ((stream udp-socket)) nil)
[6]449
[2439]450(defgeneric socket-os-fd (socket)
451  (:documentation
452   "Return the native OS's representation of the socket, or NIL if the
453socket is closed. On Unix, this is the Unix 'file descriptor', a small
454non-negative integer. Note that it is rather dangerous to mess around
455with tcp-stream fd's, as there is all sorts of buffering and asynchronous
456I/O going on above the OS level. listener-socket and udp-socket fd's are
457safer to mess with directly as there is less magic going on."))
458
[6]459;; Returns nil for closed stream...
[2439]460(defmethod socket-os-fd ((socket socket))
[6]461  (socket-device socket))
462
463;; Returns nil for closed stream
[423]464(defun local-socket-info (fd type socket)
[6]465  (and fd
466       (rlet ((sockaddr :sockaddr_in)
467              (namelen :signed))
468             (setf (pref namelen :signed) (record-length :sockaddr_in))
[423]469             (socket-call socket "getsockname" (c_getsockname fd sockaddr namelen))
[6]470             (when (= #$AF_INET (pref sockaddr :sockaddr_in.sin_family))
471               (ecase type
[10052]472                 (:host (ntohl (pref sockaddr
[10685]473                                     #-(or solaris-target windows-target) :sockaddr_in.sin_addr.s_addr
474                                     #+(or solaris-target windows-target) #>sockaddr_in.sin_addr.S_un.S_addr)))
[1539]475                 (:port (ntohs (pref sockaddr :sockaddr_in.sin_port))))))))
[6]476
[10685]477#-windows-target
[6]478(defun path-from-unix-address (addr)
[10052]479  (when (= #$AF_UNIX (pref addr :sockaddr_un.sun_family))
[4994]480    #+darwin-target
[6]481    (%str-from-ptr (pref addr :sockaddr_un.sun_path)
482                   (- (pref addr :sockaddr_un.sun_len) 2))
[5561]483    #-darwin-target
[6]484    (%get-cstring (pref addr :sockaddr_un.sun_path))))
485
[10685]486#-windows-target
[423]487(defun local-socket-filename (fd socket)
[6]488  (and fd
489       (rlet ((addr :sockaddr_un)
490              (namelen :signed))
491         (setf (pref namelen :signed) (record-length :sockaddr_un))
[423]492         (socket-call socket "getsockname" (c_getsockname fd addr namelen))
[6]493         (path-from-unix-address addr))))
494
[768]495(defmacro with-if ((var expr) &body body)
496  `(let ((,var ,expr))
497     (if ,var
498         (progn
499           ,@body))))     
[6]500
[768]501(defun remote-socket-info (socket type)
502  (with-if (fd (socket-device socket))
503    (rlet ((sockaddr :sockaddr_in)
504           (namelen :signed))
505          (setf (pref namelen :signed) (record-length :sockaddr_in))
506          (let ((err (c_getpeername fd sockaddr namelen)))
[10685]507            (cond ((eql err (- #+windows-target #$WSAENOTCONN #-windows-target #$ENOTCONN)) nil)
[768]508                  ((< err 0) (socket-error socket "getpeername" err))
509                  (t
510                   (when (= #$AF_INET (pref sockaddr :sockaddr_in.sin_family))
511                     (ecase type
[10052]512                       (:host (ntohl (pref sockaddr
[10685]513                                           #-(or solaris-target windows-target) :sockaddr_in.sin_addr.s_addr
514                                           #+(or solaris-target windows-target)  #>sockaddr_in.sin_addr.S_un.S_addr)))
[1539]515                       (:port (ntohs  (pref sockaddr :sockaddr_in.sin_port)))))))))))
[6]516
[10685]517#-windows-target
[768]518(defun remote-socket-filename (socket)
519  (with-if (fd (socket-device socket))
520    (rlet ((addr :sockaddr_un)
521           (namelen :signed))
522          (setf (pref namelen :signed) (record-length :sockaddr_un))
523          (let* ((err (c_getsockname fd addr namelen)))
524            (cond ((eql err (- #$ENOTCONN)) nil)
525                  ((< err 0) (socket-error socket "getpeername" err))
526                  (t (path-from-unix-address addr)))))))
[6]527
[2439]528(defgeneric local-port (socket)
529  (:documentation "Return the local port number."))
530
531(defmethod local-port ((socket socket))
[812]532  (local-socket-info (socket-device socket) :port socket))
[6]533
[2439]534(defgeneric local-host (socket)
535  (:documentation
536   "Return 32-bit unsigned IP address of the local host."))
537
538(defmethod local-host ((socket socket))
[812]539  (local-socket-info (socket-device socket) :host socket))
[6]540
[10865]541#-windows-target
[2439]542(defmethod local-filename ((socket socket))
[8760]543  (local-socket-filename (socket-device socket) socket))
[6]544
[2439]545(defgeneric remote-host (socket)
546  (:documentation
547   "Return the 32-bit unsigned IP address of the remote host, or NIL if
548the socket is not connected."))
549
[6]550;; Returns NIL if socket is not connected
[2439]551(defmethod remote-host ((socket socket))
[768]552  (remote-socket-info socket :host))
[6]553
[2439]554(defgeneric remote-port (socket)
555  (:documentation
556   "Return the remote port number, or NIL if the socket is not connected."))
557
558(defmethod remote-port ((socket socket))
[768]559  (remote-socket-info socket :port))
[6]560
[10865]561#-windows-target
[2439]562(defmethod remote-filename ((socket socket))
[768]563  (remote-socket-filename socket))
[6]564 
[10685]565(defun set-socket-fd-blocking (fd block-flag)
566  #+windows-target
[11081]567  (rlet ((argp :u_long (if block-flag 0 1)))
[11209]568    (#_ioctlsocket fd #$FIONBIO argp))
[10685]569  #-windows-target
570  (if block-flag
571    (fd-clear-flag fd #$O_NONBLOCK)
572    (fd-set-flag fd #$O_NONBLOCK)))
573
574(defun get-socket-fd-blocking (fd)
575  "returns T iff socket is in blocking mode"
576  #+windows-target (declare (ignore fd))
577  #+windows-target t
578  #-windows-target
579  (not (logtest #$O_NONBLOCK (fd-get-flags fd))))
580
[768]581(defun set-socket-options (fd-or-socket &key 
582                           keepalive
583                           reuse-address
584                           nodelay
585                           broadcast
586                           linger
587                           address-family
588                           local-port
589                           local-host
590                           local-filename
591                           type
592                           connect
593                           out-of-band-inline
594                           &allow-other-keys)
[6]595  ;; see man socket(7) tcp(7) ip(7)
[768]596  (multiple-value-bind (socket fd) (etypecase fd-or-socket
597                                     (socket (values fd-or-socket (socket-device fd-or-socket)))
598                                     (integer (values nil fd-or-socket)))
599   
600    (if (null address-family)
601        (setq address-family :internet))
602    (when keepalive
603      (int-setsockopt fd #$SOL_SOCKET #$SO_KEEPALIVE 1))
604    (when reuse-address
605      (int-setsockopt fd #$SOL_SOCKET #$SO_REUSEADDR 1))
606    (when broadcast
607      (int-setsockopt fd #$SOL_SOCKET #$SO_BROADCAST 1))
608    (when out-of-band-inline
609      (int-setsockopt fd #$SOL_SOCKET #$SO_OOBINLINE 1))
[12165]610    (when (eq address-family :internet)
611      (when (eq type :stream)
612        (rlet ((plinger :linger))
[768]613          (setf (pref plinger :linger.l_onoff) (if linger 1 0)
614                (pref plinger :linger.l_linger) (or linger 0))
615          (socket-call socket "setsockopt"
[12165]616                       (c_setsockopt fd #$SOL_SOCKET #$SO_LINGER
617                                     plinger (record-length :linger)))))
[768]618      (when nodelay
619        (int-setsockopt fd
[3809]620                        #+linux-target #$SOL_TCP
[10052]621                        #-linux-target #$IPPROTO_TCP
[768]622                        #$TCP_NODELAY 1))
623      (when (or local-port local-host)
624        (let* ((proto (if (eq type :stream) "tcp" "udp"))
625               (port-n (if local-port (port-as-inet-port local-port proto) 0))
626               (host-n (if local-host (host-as-inet-host local-host) #$INADDR_ANY)))
627          ;; Darwin includes the SIN_ZERO field of the sockaddr_in when
628          ;; comparing the requested address to the addresses of configured
629          ;; interfaces (as if the zeros were somehow part of either address.)
630          ;; "rletz" zeros out the stack-allocated structure, so those zeros
631          ;; will be 0.
632          (rletz ((sockaddr :sockaddr_in))
633                 (setf (pref sockaddr :sockaddr_in.sin_family) #$AF_INET
634                       (pref sockaddr :sockaddr_in.sin_port) port-n
[10052]635                       (pref sockaddr
[10685]636                             #-(or solaris-target windows-target) :sockaddr_in.sin_addr.s_addr
637                             #+(or solaris-target windows-target) #>sockaddr_in.sin_addr.S_un.S_addr
[10052]638                             ) host-n)
[768]639                 (socket-call socket "bind" (c_bind fd sockaddr (record-length :sockaddr_in)))))))
640    (when (and (eq address-family :file)
641               (eq connect :passive)
642               local-filename)
[10865]643      #+windows-target (error "can't create file socket on Windows")
644      #-windows-target (bind-unix-socket fd local-filename))))
[6]645
646;; I hope the inline declaration makes the &rest/apply's go away...
647(declaim (inline make-ip-socket))
648(defun make-ip-socket (&rest keys &key type &allow-other-keys)
649  (declare (dynamic-extent keys))
650  (ecase type
651    ((nil :stream) (apply #'make-tcp-socket keys))
652    ((:datagram) (apply #'make-udp-socket keys))))
653
654(declaim (inline make-file-socket))
655(defun make-file-socket (&rest keys &key type &allow-other-keys)
656  (declare (dynamic-extent keys))
657  (ecase type
658    ((nil :stream) (apply #'make-stream-file-socket keys))
659    (:datagram (apply #'make-datagram-file-socket keys))))
660
[2439]661(defun make-socket (&rest keys
[6]662                    &key address-family
663                    ;; List all keys here just for error checking...
664                    ;; &allow-other-keys
665                    type connect remote-host remote-port eol format
666                    keepalive reuse-address nodelay broadcast linger
667                    local-port local-host backlog class out-of-band-inline
[5375]668                    local-filename remote-filename sharing basic
[7978]669                    external-format (auto-close t)
[12089]670                    connect-timeout input-timeout output-timeout deadline
671                    fd)
[2439]672  "Create and return a new socket."
[6]673  (declare (dynamic-extent keys))
674  (declare (ignore type connect remote-host remote-port eol format
675                   keepalive reuse-address nodelay broadcast linger
676                   local-port local-host backlog class out-of-band-inline
[7624]677                   local-filename remote-filename sharing basic external-format
[12105]678                   auto-close connect-timeout input-timeout output-timeout deadline fd))
[6]679  (ecase address-family
680    ((:file) (apply #'make-file-socket keys))
681    ((nil :internet) (apply #'make-ip-socket keys))))
682
683
684
[12089]685(defun make-udp-socket (&rest keys &key (fd -1) &allow-other-keys)
[6]686  (unwind-protect
687    (let (socket)
[12089]688      (when (< fd 0)
689        (setq fd (socket-call nil "socket"
690                              (c_socket #$AF_INET #$SOCK_DGRAM #$IPPROTO_UDP))))
[6]691      (apply #'set-socket-options fd keys)
692      (setq socket (make-instance 'udp-socket
693                                  :device fd
694                                  :keys keys))
695      (setq fd -1)
696      socket)
697    (unless (< fd 0)
698      (fd-close fd))))
699
[12089]700(defun make-tcp-socket (&rest keys &key connect (fd -1) &allow-other-keys)
[6]701  (unwind-protect
[12089]702       (let (socket)
703         (when (< fd 0)
704           (setq fd (socket-call nil "socket"
705                                 (c_socket #$AF_INET #$SOCK_STREAM #$IPPROTO_TCP))))
706         (apply #'set-socket-options fd keys)
707         (setq socket
708               (ecase connect
709                 ((nil :active) (apply #'make-tcp-stream-socket fd keys))
710                 ((:passive) (apply #'make-tcp-listener-socket fd keys))))
711         (setq fd -1)
712         socket)
[6]713    (unless (< fd 0)
714      (fd-close fd))))
715
[12089]716(defun make-stream-file-socket (&rest keys &key connect (fd -1) &allow-other-keys)
[6]717  (unwind-protect
[12089]718       (let (socket)
719         (when (< fd 0)
720           (setq fd (socket-call nil "socket" (c_socket #$PF_UNIX #$SOCK_STREAM 0))))
721         (apply #'set-socket-options fd keys)
722         (setq socket
723               (ecase connect
724                 ((nil :active) (apply #'make-file-stream-socket fd keys))
725                 ((:passive) (apply #'make-file-listener-socket fd keys))))
726         (setq fd -1)
727         socket)
[6]728    (unless (< fd 0)
729      (fd-close fd))))
730
[12033]731(defun make-datagram-file-socket (&rest keys)
732  (declare (ignore keys))
733  (error "Datagram file sockets aren't implemented."))
734
735
[8941]736(defun %socket-connect (fd addr addrlen &optional timeout-in-milliseconds)
737  (let* ((err (c_connect fd addr addrlen timeout-in-milliseconds)))
[6]738    (declare (fixnum err))
[8941]739    (unless (eql err 0) (fd-close fd) (socket-error nil "connect" err))))
[6]740   
[8941]741(defun inet-connect (fd host-n port-n &optional timeout-in-milliseconds)
[6]742  (rlet ((sockaddr :sockaddr_in))
743    (setf (pref sockaddr :sockaddr_in.sin_family) #$AF_INET
744          (pref sockaddr :sockaddr_in.sin_port) port-n
[10052]745          (pref sockaddr
[10685]746                #-(or solaris-target windows-target) :sockaddr_in.sin_addr.s_addr
747                #+(or solaris-target windows-target)  #>sockaddr_in.sin_addr.S_un.S_addr
[10052]748                ) host-n)
[8941]749    (%socket-connect fd sockaddr (record-length :sockaddr_in) timeout-in-milliseconds)))
[10685]750
751#-windows-target
[6]752(defun file-socket-connect (fd remote-filename)
753  (rletz ((sockaddr :sockaddr_un))
754    (init-unix-sockaddr sockaddr remote-filename)
755    (%socket-connect fd sockaddr (record-length :sockaddr_un))))
[10865]756
757#+windows-target
758(defun file-socket-connect (fd remote-filename)
759  (declare (ignore fd))
760  (error "Can't create file socket to ~s on Windows" remote-filename))
[6]761 
[5826]762(defun make-tcp-stream-socket (fd &rest keys
763                                  &key remote-host
[8385]764                                  remote-port
765                                  connect-timeout
[8941]766                                  deadline
[6]767                                  &allow-other-keys)
[8941]768  (let* ((timeout-in-milliseconds
769          (if deadline
770            (max (round (- deadline (get-internal-real-time))
771                        (/ internal-time-units-per-second 1000))
772                 0)
773            (if connect-timeout
774              (round (* connect-timeout 1000))))))
775    (inet-connect fd
776                  (host-as-inet-host remote-host)
777                  (port-as-inet-port remote-port "tcp")
778                  timeout-in-milliseconds)
779    (apply #'make-tcp-stream fd keys)))
[6]780
[5826]781(defun make-file-stream-socket (fd &rest keys
782                                   &key remote-filename
[6]783                                   &allow-other-keys)
784  (file-socket-connect fd remote-filename)
[5826]785  (apply #'make-file-socket-stream fd keys))
[6]786
787
[8603]788(defun make-tcp-stream (fd
789                        &key (format :bivalent)
790                             external-format
791                             (class 'tcp-stream)
792                             sharing
793                             (basic t)
794                             (auto-close t)
795                             input-timeout
796                             output-timeout
797                             deadline
798                        &allow-other-keys)
[5375]799  (let* ((external-format (normalize-external-format :socket external-format)))
800    (let ((element-type (ecase format
801                          ((nil :text) 'character)
802                          ((:binary :bivalent) '(unsigned-byte 8)))))
803      ;; TODO: check out fd-stream-advance, -listen, -eofp, -force-output, -close
804      ;; See if should specialize any of 'em.
805      (make-fd-stream fd
806                      :class class
807                      :direction :io
808                      :element-type element-type
809                      :sharing sharing
[6914]810                      :character-p (not (eq format :binary))
[5375]811                      :encoding (external-format-character-encoding external-format)
812                      :line-termination (external-format-line-termination external-format)
[7624]813                      :basic basic
[8603]814                      :auto-close auto-close
815                      :input-timeout input-timeout
816                      :output-timeout output-timeout
817                      :deadline deadline))))
[6]818
[8603]819(defun make-file-socket-stream (fd
820                                &key (format :bivalent)
821                                external-format
822                                (class 'file-socket-stream)
823                                sharing
824                                basic
825                                (auto-close t)
826                                input-timeout
827                                output-timeout
828                                deadline
829                                &allow-other-keys)
[5375]830  (let* ((external-format (normalize-external-format :socket external-format)))
831 
832    (let ((element-type (ecase format
833                          ((nil :text) 'character)
834                          ((:binary :bivalent) '(unsigned-byte 8)))))
835      ;; TODO: check out fd-stream-advance, -listen, -eofp, -force-output, -close
836      ;; See if should specialize any of 'em.
837      (make-fd-stream fd
838                      :class class
839                      :direction :io
840                      :element-type element-type
841                      :encoding (external-format-character-encoding external-format)
842                      :line-termination (external-format-line-termination external-format)
843                      :sharing sharing
[6914]844                      :character-p (not (eq format :binary))
[7624]845                      :basic basic
[8604]846                      :auto-close auto-close
847                      :input-timeout input-timeout
848                      :output-timeout output-timeout
849                      :deadline deadline))))
[6]850
851(defun make-tcp-listener-socket (fd &rest keys &key backlog &allow-other-keys)
[423]852  (socket-call nil "listen" (c_listen fd (or backlog 5)))
[6]853  (make-instance 'listener-socket
854                 :device fd
855                 :keys keys))
856
857(defun make-file-listener-socket (fd &rest keys &key backlog &allow-other-keys)
[423]858  (socket-call nil "listen" (c_listen fd (or backlog 5)))
[6]859  (make-instance 'file-listener-socket
860                 :device fd
861                 :keys keys))
862
[10685]863(defun socket-accept (fd wait)
[6]864  (flet ((_accept (fd async)
865           (let ((res (c_accept fd (%null-ptr) (%null-ptr))))
866             (declare (fixnum res))
867             ;; See the inscrutable note under ERROR HANDLING in
868             ;; man accept(2). This is my best guess at what they mean...
869             (if (and async (< res 0)
[10685]870                      #+windows-target
871                      (= res #$WSAEWOULDBLOCK)
872                      #-windows-target
[6]873                      (or (eql res (- #$ENETDOWN))
[3809]874                          (eql res (- #+linux-target #$EPROTO
[10052]875                                      #-linux-target  #$EPROTOTYPE))
[6]876                          (eql res (- #$ENOPROTOOPT))
877                          (eql res (- #$EHOSTDOWN))
[3822]878                          (eql res (- #+linux-target #$ENONET
[10052]879                                      #-linux-target #$ENETDOWN))
[6]880                          (eql res (- #$EHOSTUNREACH))
881                          (eql res (- #$EOPNOTSUPP))
882                          (eql res (- #$ENETUNREACH))))
883               (- #$EAGAIN)
[11081]884               res))))
[6]885    (cond (wait
886            (with-eagain fd :input
887              (_accept fd *multiprocessing-socket-io*)))
888          (*multiprocessing-socket-io*
889            (_accept fd t))
890          (t
[10685]891            (let ((was-blocking (get-socket-fd-blocking fd)))
[6]892              (unwind-protect
893                  (progn
[10685]894                    (set-socket-fd-blocking fd nil)
[6]895                    (_accept fd t))
[10685]896                (set-socket-fd-blocking fd was-blocking)))))))
[6]897
[12463]898(defun accept-socket-connection (socket wait stream-create-function &optional stream-args)
[6]899  (let ((listen-fd (socket-device socket))
900        (fd -1))
901    (unwind-protect
[12463]902      (let ((keys (append stream-args (socket-keys socket))))
[10685]903        (setq fd (socket-accept listen-fd wait))
[6]904        (cond ((>= fd 0)
[12463]905               (prog1 (apply stream-create-function fd keys)
[6]906                 (setq fd -1)))
907              ((eql fd (- #$EAGAIN)) nil)
[768]908              (t (socket-error socket "accept" fd))))
[6]909      (when (>= fd 0)
910        (fd-close fd)))))
911
[12463]912(defgeneric accept-connection (socket &key wait stream-args)
[2439]913  (:documentation
914  "Extract the first connection on the queue of pending connections,
915accept it (i.e. complete the connection startup protocol) and return a new
916tcp-stream or file-socket-stream representing the newly established
917connection.  The tcp stream inherits any properties of the listener socket
[12463]918that are relevant (e.g. :keepalive, :nodelay, etc.) Additional arguments
919may be specified using STREAM-ARGS. The original listener
[2439]920socket continues to be open listening for more connections, so you can call
921accept-connection on it again."))
922
[12463]923(defmethod accept-connection ((socket listener-socket) &key (wait t) stream-args)
924  (accept-socket-connection socket wait #'make-tcp-stream stream-args))
[6]925
[12463]926(defmethod accept-connection ((socket file-listener-socket) &key (wait t) stream-args)
927  (accept-socket-connection socket wait #'make-file-socket-stream stream-args))
[6]928
929(defun verify-socket-buffer (buf offset size)
930  (unless offset (setq offset 0))
931  (unless (<= (+ offset size) (length buf))
932    (report-bad-arg size `(integer 0 ,(- (length buf) offset))))
933  (multiple-value-bind (arr start) (array-data-and-offset buf)
934    (setq buf arr offset (+ offset start)))
935  ;; TODO: maybe should allow any raw vector
936  (let ((subtype (typecode buf)))
[1966]937    (unless #+ppc32-target (and (<= ppc32::min-8-bit-ivector-subtag subtype)
938                                (<= subtype ppc32::max-8-bit-ivector-subtag))
939            #+ppc64-target (= (the fixnum (logand subtype ppc64::fulltagmask))
940                              ppc64::ivector-class-8-bit)
[10136]941            #+x8632-target (and (<= x8632::min-8-bit-ivector-subtag subtype)
942                                (<= subtype x8632::max-8-bit-ivector-subtag))
[3978]943            #+x8664-target (and (>= subtype x8664::min-8-bit-ivector-subtag)
944                                (<= subtype x8664::max-8-bit-ivector-subtag))
[6]945      (report-bad-arg buf `(or (array character)
946                               (array (unsigned-byte 8))
947                               (array (signed-byte 8))))))
948  (values buf offset))
949
[2439]950(defmethod send-to ((socket udp-socket) msg size
[6]951                    &key remote-host remote-port offset)
[2439]952  "Send a UDP packet over a socket."
[6]953  (let ((fd (socket-device socket)))
954    (multiple-value-setq (msg offset) (verify-socket-buffer msg offset size))
955    (unless remote-host
956      (setq remote-host (or (getf (socket-keys socket) :remote-host)
[768]957                            (remote-socket-info socket :host))))
[6]958    (unless remote-port
959      (setq remote-port (or (getf (socket-keys socket) :remote-port)
[768]960                            (remote-socket-info socket :port))))
[6]961    (rlet ((sockaddr :sockaddr_in))
962      (setf (pref sockaddr :sockaddr_in.sin_family) #$AF_INET)
[10052]963      (setf (pref sockaddr
[10685]964                  #-(or solaris-target windows-target) :sockaddr_in.sin_addr.s_addr
965                  #+(or solaris-target windows-target)  #>sockaddr_in.sin_addr.S_un.S_addr)
[6]966            (if remote-host (host-as-inet-host remote-host) #$INADDR_ANY))
967      (setf (pref sockaddr :sockaddr_in.sin_port)
968            (if remote-port (port-as-inet-port remote-port "udp") 0))
969      (%stack-block ((bufptr size))
970        (%copy-ivector-to-ptr msg offset bufptr 0 size)
[423]971        (socket-call socket "sendto"
[6]972          (with-eagain fd :output
973            (c_sendto fd bufptr size 0 sockaddr (record-length :sockaddr_in))))))))
974
[2439]975(defmethod receive-from ((socket udp-socket) size &key buffer extract offset)
976  "Read a UDP packet from a socket. If no packets are available, wait for
977a packet to arrive. Returns four values:
978  The buffer with the data
979  The number of bytes read
980  The 32-bit unsigned IP address of the sender of the data
981  The port number of the sender of the data."
[6]982  (let ((fd (socket-device socket))
983        (vec-offset offset)
984        (vec buffer)
985        (ret-size -1))
986    (when vec
987      (multiple-value-setq (vec vec-offset)
988        (verify-socket-buffer vec vec-offset size)))
989    (rlet ((sockaddr :sockaddr_in)
990           (namelen :signed))
991      (setf (pref sockaddr :sockaddr_in.sin_family) #$AF_INET)
[10052]992      (setf (pref sockaddr
[10685]993                  #-(or solaris-target windows-target) :sockaddr_in.sin_addr.s_addr
994                  #+(or solaris-target windows-target) #>sockaddr_in.sin_addr.S_un.S_addr)
[10052]995            #$INADDR_ANY)
[6]996      (setf (pref sockaddr :sockaddr_in.sin_port) 0)
997      (setf (pref namelen :signed) (record-length :sockaddr_in))
998      (%stack-block ((bufptr size))
[423]999        (setq ret-size (socket-call socket "recvfrom"
[6]1000                         (with-eagain fd :input
1001                           (c_recvfrom fd bufptr size 0 sockaddr namelen))))
1002        (unless vec
1003          (setq vec (make-array ret-size
1004                                :element-type
1005                                (ecase (socket-format socket)
[4605]1006                                  ((:text) 'base-char)
[6]1007                                  ((:binary :bivalent) '(unsigned-byte 8))))
1008                vec-offset 0))
1009        (%copy-ptr-to-ivector bufptr 0 vec vec-offset ret-size))
1010      (values (cond ((null buffer)
1011                     vec)
1012                    ((or (not extract)
1013                         (and (eql 0 (or offset 0))
1014                              (eql ret-size (length buffer))))
1015                     buffer)
1016                    (t 
1017                     (subseq vec vec-offset (+ vec-offset ret-size))))
1018              ret-size
[10052]1019              (ntohl (pref sockaddr
[10685]1020                           #-(or solaris-target windows-target) :sockaddr_in.sin_addr.s_addr
1021                           #+(or solaris-target windows-target) #>sockaddr_in.sin_addr.S_un.S_addr))
[1539]1022              (ntohs (pref sockaddr :sockaddr_in.sin_port))))))
[6]1023
[2439]1024(defgeneric shutdown (socket &key direction)
1025  (:documentation
1026   "Shut down part of a bidirectional connection. This is useful if e.g.
1027you need to read responses after sending an end-of-file signal."))
1028
1029(defmethod shutdown (socket &key direction)
[6]1030  ;; TODO: should we ignore ENOTCONN error?  (at least make sure it
1031  ;; is a distinct, catchable error type).
1032  (let ((fd (socket-device socket)))
[423]1033    (socket-call socket "shutdown"
[6]1034      (c_shutdown fd (ecase direction
1035                       (:input 0)
1036                       (:output 1))))))
1037
1038;; Accepts port as specified by user, returns port number in network byte
1039;; order.  Protocol should be one of "tcp" or "udp".  Error if not known.
1040(defun port-as-inet-port (port proto)
1041  (or (etypecase port
[1539]1042        (fixnum (htons port))
[6]1043        (string (_getservbyname port proto))
1044        (symbol (_getservbyname (string-downcase (symbol-name port)) proto)))
[768]1045      (socket-error nil "getservbyname" (- #$ENOENT))))
[6]1046
[2439]1047(defun lookup-port (port proto)
1048  "Find the port number for the specified port and protocol."
[6]1049  (if (fixnump port)
1050    port
[5494]1051    (ntohs (port-as-inet-port port proto))))
[6]1052
1053;; Accepts host as specified by user, returns host number in network byte
1054;; order.
1055(defun host-as-inet-host (host)
1056  (etypecase host
[1539]1057    (integer (htonl host))
[6]1058    (string (or (and (every #'(lambda (c) (position c ".0123456789")) host)
1059                     (_inet_aton host))
1060                (multiple-value-bind (addr err) (c_gethostbyname host)
1061                  (or addr
[768]1062                      (socket-error nil "gethostbyname" err t)))))))
[6]1063
1064
[2439]1065(defun dotted-to-ipaddr (name &key (errorp t))
1066  "Convert a dotted-string representation of a host address to a 32-bit
1067unsigned IP address."
[6]1068  (let ((addr (_inet_aton name)))
[1539]1069    (if addr (ntohl addr)
[6]1070      (and errorp (error "Invalid dotted address ~s" name)))))
1071   
[2439]1072(defun lookup-hostname (host)
1073  "Convert a host spec in any of the acceptable formats into a 32-bit
1074unsigned IP address."
[6]1075  (if (typep host 'integer)
1076    host
[1539]1077    (ntohl (host-as-inet-host host))))
[6]1078
[2439]1079(defun ipaddr-to-dotted (addr &key values)
1080  "Convert a 32-bit unsigned IP address into octets."
[11068]1081  (let* ((a (ldb (byte 8 24) addr))
1082         (b (ldb (byte 8 16) addr))
1083         (c (ldb (byte 8  8) addr))
1084         (d (ldb (byte 8  0) addr)))
1085    (if values
1086      (values a b c d)
1087      (format nil "~d.~d.~d.~d" a b c d))))
[6]1088
[2439]1089(defun ipaddr-to-hostname (ipaddr &key ignore-cache)
1090  "Convert a 32-bit unsigned IP address into a host name string."
[6]1091  (declare (ignore ignore-cache))
[1539]1092  (multiple-value-bind (name err) (c_gethostbyaddr (htonl ipaddr))
[768]1093    (or name (socket-error nil "gethostbyaddr" err t))))
[6]1094 
1095
1096(defun int-getsockopt (socket level optname)
1097  (rlet ((valptr :signed)
1098         (vallen :signed))
1099    (setf (pref vallen :signed) 4)
1100    (let* ((err (c_getsockopt socket level optname valptr vallen)))
1101      (if (and (eql 0 err)
1102               (eql 4 (pref vallen :signed)))
1103        (pref valptr :signed)
[768]1104        (socket-error socket "getsockopt" err)))))
[6]1105
[7978]1106(defun timeval-setsockopt (socket level optname timeout)
[8265]1107    (multiple-value-bind (seconds micros)
1108        (microseconds timeout)
1109      (rlet ((valptr :timeval :tv_sec seconds :tv_usec micros))
[7978]1110        (socket-call socket "setsockopt"
1111          (c_setsockopt socket level optname valptr (record-length :timeval))))))
1112                   
[6]1113(defun int-setsockopt (socket level optname optval)
1114  (rlet ((valptr :signed))
1115    (setf (pref valptr :signed) optval)
[423]1116    (socket-call socket "setsockopt"
[6]1117      (c_setsockopt socket level optname valptr (record-length :signed)))))
1118
[4857]1119
[10865]1120
[4857]1121           
[10865]1122(defun c_gethostbyaddr (addr-in-net-byte-order)
1123  (rletZ ((sin #>sockaddr_in))
1124    (setf (pref sin :sockaddr_in.sin_family) #$AF_INET
1125          (pref sin
1126                #+(or windows-target solaris-target) #>sockaddr_in.sin_addr.S_un.S_addr
1127                #-(or windows-target solaris-target) #>sockaddr_in.sin_addr.s_addr) addr-in-net-byte-order)
1128    #+darwin-target (setf (pref sin :sockaddr_in.sin_len) (record-length :sockaddr_in))
1129    (%stack-block ((namep #$NI_MAXHOST))
1130      (let* ((err (#_getnameinfo sin (record-length #>sockaddr_in) namep #$NI_MAXHOST (%null-ptr) 0 #$NI_NAMEREQD)))
1131        (if (eql 0 err)
1132          (%get-cstring namep)
1133          (values nil err))))))
1134               
[6]1135(defun c_gethostbyname (name)
1136  (with-cstrs ((name (string name)))
[10865]1137    (rletZ ((hints #>addrinfo)
1138            (results :address))
1139      (setf (pref hints #>addrinfo.ai_family) #$AF_INET)
1140      (let* ((err (#_getaddrinfo name (%null-ptr) hints results)))
1141        (if (eql 0 err)
1142          (let* ((info (pref results :address))
1143                 (sin (pref info #>addrinfo.ai_addr)))
1144            (prog1
1145                #+(or windows-target solaris-target)
1146                (pref sin #>sockaddr_in.sin_addr.S_un.S_addr)
1147                #-(or windows-target solaris-target)
1148                (pref sin #>sockaddr_in.sin_addr.s_addr)
1149                (#_freeaddrinfo info)))
1150          (values nil err))))))
1151     
1152 
[6]1153
[10109]1154 
1155
[6]1156(defun _getservbyname (name proto)
1157  (with-cstrs ((name (string name))
1158               (proto (string proto)))
1159    (let* ((servent-ptr (%null-ptr)))
1160      (declare (dynamic-extent servent-ptr))
1161      (%setf-macptr servent-ptr (#_getservbyname name proto))
1162      (unless (%null-ptr-p servent-ptr)
1163        (pref servent-ptr :servent.s_port)))))
1164
1165(defun _inet_aton (string)
1166  (with-cstrs ((name string))
[10685]1167    #-windows-target
[6]1168    (rlet ((addr :in_addr))
[4828]1169      (let* ((result #+freebsd-target (#___inet_aton name addr)
1170                     #-freebsd-target (#_inet_aton name addr)))
[6]1171        (unless (eql result 0)
[10052]1172          (pref addr
1173                #-solaris-target :in_addr.s_addr
1174                #+solaris-target #>in_addr.S_un.S_addr
[10685]1175                ))))
1176    #+windows-target
1177    (rlet ((addr :sockaddr_in)
1178           (addrlenp :int (record-length :sockaddr_in)))
1179      (setf (pref addr :sockaddr_in.sin_family) #$AF_INET)
1180      (when (zerop (#_WSAStringToAddressA name #$AF_INET (%null-ptr)  addr addrlenp))
1181        (pref addr #>sockaddr_in.sin_addr.S_un.S_addr)))))
[6]1182
[7624]1183(defun c_socket_1 (domain type protocol)
[10574]1184  #-windows-target (int-errno-call (#_socket domain type protocol))
1185  #+windows-target (let* ((handle (#_socket domain type protocol)))
1186                     (if (< handle 0)
1187                       (%get-winsock-error)
[11081]1188                       handle)))
[6]1189
[10574]1190
1191
[7624]1192(defun c_socket (domain type protocol)
1193  (let* ((fd (c_socket_1 domain type protocol)))
1194    (when (or (eql fd (- #$EMFILE))
1195              (eql fd (- #$ENFILE)))
1196      (gc)
1197      (drain-termination-queue)
1198      (setq fd (c_socket_1 domain type protocol)))
1199    fd))
1200     
1201
[10685]1202#-windows-target
[6]1203(defun init-unix-sockaddr (addr path)
1204  (macrolet ((sockaddr_un-path-len ()
1205               (/ (ensure-foreign-type-bits
[5559]1206                   (foreign-record-field-type 
1207                    (%find-foreign-record-type-field
1208                     (parse-foreign-type '(:struct :sockaddr_un)) :sun_path)))
[6]1209                  8)))
1210    (let* ((name (native-translated-namestring path))
1211           (namelen (length name))
1212           (pathlen (sockaddr_un-path-len))
1213           (copylen (min (1- pathlen) namelen)))
[10052]1214      (setf (pref addr :sockaddr_un.sun_family) #$AF_UNIX)
[5559]1215      (let* ((sun-path (pref addr :sockaddr_un.sun_path)))
1216        (dotimes (i copylen)
1217          (setf (%get-unsigned-byte sun-path i)
1218                (let* ((code (char-code (schar name i))))
1219                  (if (> code 255)
1220                    (char-code #\Sub)
1221                    code))))))))
[6]1222
[10685]1223#-windows-target
[6]1224(defun bind-unix-socket (socketfd path)
1225  (rletz ((addr :sockaddr_un))
1226    (init-unix-sockaddr addr path)
1227    (socket-call
[423]1228     nil
[6]1229     "bind"
1230     (c_bind socketfd
1231             addr
1232             (+ 2
1233                (#_strlen
1234                 (pref addr :sockaddr_un.sun_path)))))))
1235     
1236
1237(defun c_bind (sockfd sockaddr addrlen)
[11081]1238  (check-socket-error (#_bind sockfd sockaddr addrlen)))
[6]1239
1240
[10698]1241#+windows-target
1242(defun windows-connect-wait (sockfd timeout-in-milliseconds)
1243  (if (and timeout-in-milliseconds
1244           (< timeout-in-milliseconds 0))
1245    (setq timeout-in-milliseconds nil))
1246  (rlet ((writefds :fd_set)
1247         (exceptfds :fd_set)
1248         (tv :timeval :tv_sec 0 :tv_usec 0))
[11081]1249    (fd-zero writefds)
1250    (fd-zero exceptfds)
1251    (fd-set sockfd writefds)
1252    (fd-set sockfd exceptfds)
1253    (when timeout-in-milliseconds
1254      (multiple-value-bind (seconds milliseconds)
1255          (floor timeout-in-milliseconds 1000)
1256        (setf (pref tv :timeval.tv_sec) seconds
1257              (pref tv :timeval.tv_usec) (* 1000 milliseconds))))
1258    (> (#_select 1 (%null-ptr) writefds exceptfds (if timeout-in-milliseconds tv (%null-ptr))) 0)))
[10698]1259     
1260     
[8265]1261;;; If attempts to connnect are interrupted, we basically have to
1262;;; wait in #_select (or the equivalent).  There's a good rant
1263;;; about these issues in:
1264;;; <http://www.madore.org/~david/computers/connect-intr.html>
[8941]1265(defun c_connect (sockfd addr len &optional timeout-in-milliseconds)
[10685]1266  (let* ((was-blocking (get-socket-fd-blocking sockfd)))
[8385]1267    (unwind-protect
1268         (progn
[10685]1269           (set-socket-fd-blocking sockfd nil)
[11081]1270           (let* ((err (check-socket-error (#_connect sockfd addr len))))
[10685]1271             (cond ((or (eql err (- #+windows-target #$WSAEINPROGRESS
[10698]1272                                   
1273                                    #-windows-target #$EINPROGRESS))
1274                        #+windows-target (eql err (- #$WSAEWOULDBLOCK))
1275                        (eql err (- #$EINTR)))
1276                    (if
1277                      #+windows-target (windows-connect-wait sockfd timeout-in-milliseconds)
1278                      #-windows-target (process-output-wait sockfd timeout-in-milliseconds)
[8385]1279                      (- (int-getsockopt sockfd #$SOL_SOCKET #$SO_ERROR))
[10685]1280                      (- #+windows-target #$WSAETIMEDOUT #-windows-target #$ETIMEDOUT)))
[8385]1281                   (t err))))
[10685]1282      (set-socket-fd-blocking sockfd was-blocking))))
[8265]1283
[6]1284(defun c_listen (sockfd backlog)
[11081]1285  (check-socket-error (#_listen sockfd backlog)))
[6]1286
1287(defun c_accept (sockfd addrp addrlenp)
[10544]1288  (ignoring-eintr
[11081]1289   (check-socket-error (#_accept sockfd addrp addrlenp))))
[6]1290
1291(defun c_getsockname (sockfd addrp addrlenp)
[11081]1292  (check-socket-error (#_getsockname sockfd addrp addrlenp)))
[6]1293
1294(defun c_getpeername (sockfd addrp addrlenp)
[11081]1295  (check-socket-error (#_getpeername sockfd addrp addrlenp)))
[6]1296
[10685]1297#-windows-target
[6]1298(defun c_socketpair (domain type protocol socketsptr)
[10574]1299  (check-socket-error (#_socketpair domain type protocol socketsptr)))
[6]1300
1301
1302(defun c_sendto (sockfd msgptr len flags addrp addrlen)
[11758]1303  (ignoring-eintr (check-socket-error (#_sendto sockfd msgptr len flags addrp addrlen))))
[6]1304
1305(defun c_recvfrom (sockfd bufptr len flags addrp addrlenp)
[11758]1306  (ignoring-eintr (check-socket-error (#_recvfrom sockfd bufptr len flags addrp addrlenp))))
[6]1307
1308(defun c_shutdown (sockfd how)
[11081]1309  (check-socket-error (#_shutdown sockfd how)))
[6]1310
1311(defun c_setsockopt (sockfd level optname optvalp optlen)
[11081]1312  (check-socket-error (#_setsockopt sockfd level optname optvalp optlen)))
[6]1313
1314(defun c_getsockopt (sockfd level optname optvalp optlenp)
[11081]1315  (check-socket-error (#_getsockopt sockfd level optname optvalp optlenp)))
[6]1316
[10685]1317#-windows-target
[6]1318(defun c_sendmsg (sockfd msghdrp flags)
[11081]1319  (check-socket-error (#_sendmsg sockfd msghdrp flags)))
[6]1320
[10685]1321#-windows-target
[6]1322(defun c_recvmsg (sockfd msghdrp flags)
[11081]1323  (check-socket-error   (#_recvmsg sockfd msghdrp flags)))
[6]1324
1325;;; Return a list of currently configured interfaces, a la ifconfig.
1326(defstruct ip-interface
1327  name
1328  addr
1329  netmask
1330  flags
1331  address-family)
1332
1333(defun dump-buffer (p n)
1334  (dotimes (i n (progn (terpri) (terpri)))
1335    (unless (logtest i 15)
1336      (format t "~&~8,'0x: " (%ptr-to-int (%inc-ptr p i))))
1337    (format t " ~2,'0x" (%get-byte p i))))
1338
[10685]1339#-(or windows-target solaris-target)
[6]1340(defun %get-ip-interfaces ()
[2036]1341  (rlet ((p :address (%null-ptr)))
1342    (if (zerop (#_getifaddrs p))
1343      (unwind-protect
1344           (do* ((q (%get-ptr p) (pref q :ifaddrs.ifa_next))
1345                 (res ()))
1346                ((%null-ptr-p q) (nreverse res))
1347             (let* ((addr (pref q :ifaddrs.ifa_addr)))
[7732]1348               (when (and (not (%null-ptr-p addr))
1349                          (eql (pref addr :sockaddr.sa_family) #$AF_INET))
[2036]1350                 (push (make-ip-interface
[10052]1351                        :name (%get-cstring (pref q :ifaddrs.ifa_name))
[10698]1352                        :addr (ntohl (pref addr :sockaddr_in.sin_addr.s_addr))
[10865]1353                        :netmask (ntohl
1354                                  (pref (pref q :ifaddrs.ifa_netmask)
1355                                       :sockaddr_in.sin_addr.s_addr))
[10109]1356                        :flags (pref q :ifaddrs.ifa_flags)
1357                        :address-family #$AF_INET)
1358                       res))))
1359        (#_freeifaddrs (pref p :address))))))
[6]1360
[10109]1361#+solaris-target
1362(progn
1363  ;;; Interface translator has trouble with a lot of ioctl constants.
1364  (eval-when (:compile-toplevel :execute)
1365    (defconstant os::|SIOCGLIFNUM| #xc00c6982)
1366    (defconstant os::|SIOCGLIFCONF| #xc01069a5)
1367    (defconstant os::|SIOCGLIFADDR| #xc0786971)
1368    (defconstant os::|SIOCGLIFFLAGS| #xc0786975)
1369    (defconstant os::|SIOCGLIFNETMASK| #xc078697d)
1370    )
[6]1371
[10109]1372(defun %get-ip-interfaces ()
1373  (let* ((sock (c_socket #$AF_INET #$SOCK_DGRAM #$IPPROTO_UDP))
1374         (res nil))
1375    (when (>= sock 0)
1376      (unwind-protect
1377           (let* ((flags (logior #$LIFC_NOXMIT #$LIFC_TEMPORARY #$LIFC_ALLZONES))
1378                  (ninterfaces (rlet ((lifnum :lifnum
1379                                        :lifn_flags flags
1380                                        :lifn_family #$AF_INET
1381                                        :lifn_count 0))
1382                                 (#_ioctl sock os::SIOCGLIFNUM :address lifnum)
1383                                 (pref lifnum :lifnum.lifn_count))))
1384             (declare (fixnum ninterfaces))
1385             (when (> ninterfaces 0)
1386               (let* ((bufsize (* ninterfaces (record-length :lifreq))))
1387                 (%stack-block ((buf bufsize :clear t))
1388                   (rlet ((lifc :lifconf
1389                            :lifc_family #$AF_INET
1390                            :lifc_flags flags
1391                            :lifc_len bufsize
1392                            :lifc_lifcu.lifcu_buf buf))
1393                     (when (>= (#_ioctl sock os::SIOCGLIFCONF :address lifc) 0)
1394                       (do* ((i 0 (1+ i))
1395                             (p (pref lifc :lifconf.lifc_lifcu.lifcu_buf)
1396                                (%inc-ptr p (record-length :lifreq))))
1397                            ((= i ninterfaces))
1398                         (let* ((name (%get-cstring (pref p :lifreq.lifr_name)))
1399                                (address-family (pref p :lifreq.lifr_lifru.lifru_addr.ss_family))
1400                                (if-flags nil)
1401                                (address nil)
1402                                (netmask nil))
1403                           (if (>= (#_ioctl sock os::SIOCGLIFFLAGS :address p)
1404                                   0)
1405                             (setq if-flags (pref p :lifreq.lifr_lifru.lifru_flags)))
1406                           (if (>= (#_ioctl sock os::SIOCGLIFADDR :address p)
1407                                   0)
1408                             (setq address (pref
1409                                            (pref p :lifreq.lifr_lifru.lifru_addr)
1410                                            #>sockaddr_in.sin_addr.S_un.S_addr)))
1411                           (if (>= (#_ioctl sock os::SIOCGLIFNETMASK :address p)
1412                                   0)
1413                             (setq netmask (pref
1414                                            (pref p :lifreq.lifr_lifru.lifru_subnet)
1415                                            #>sockaddr_in.sin_addr.S_un.S_addr)))
1416                             
1417                           (push (make-ip-interface
1418                                  :name name
[10698]1419                                  :addr (ntohl address)
[10865]1420                                  :netmask (ntohl netmask)
[10109]1421                                  :flags if-flags
1422                                  :address-family address-family)
1423                                 res)))))))))
1424        (fd-close sock)))
1425    res))
1426)
1427
1428
[10865]1429
1430
1431#+windows-target
1432(defun %get-ip-interfaces ()
[12267]1433  (let* ((socket (#_socket #$AF_INET #$SOCK_DGRAM #$IPPROTO_IP)))
[10865]1434    (unwind-protect
1435    (rlet ((realoutlen #>DWORD 0))
1436      (do* ((reservedlen (* 4 (record-length #>INTERFACE_INFO))
1437                         (* 2 reservedlen)))
1438           ()
1439        (%stack-block ((buf reservedlen))
1440          (unless (eql 0 (#_WSAIoctl
[12267]1441                          socket
[10865]1442                          #$SIO_GET_INTERFACE_LIST
1443                          (%null-ptr)
1444                          0
1445                          buf
1446                          reservedlen
1447                          realoutlen
1448                          (%null-ptr)
1449                          (%null-ptr)))
1450            (return))
1451          (let* ((noutbytes (pref realoutlen #>DWORD)))
1452            (when (< noutbytes reservedlen)
1453              (let* ((interfaces nil))
1454                (do* ((offset 0 (+ offset (record-length #>INTERFACE_INFO)))
1455                      (nameidx 0 (1+ nameidx)))
1456                     ((>= offset noutbytes))
1457                  (with-macptrs ((p (%inc-ptr buf offset)))
1458                    (push (make-ip-interface 
1459                           :name (format nil "ip~d" nameidx)
1460                           :addr (ntohl
1461                                  (pref (pref p #>INTERFACE_INFO.iiAddress)
1462                                        #>sockaddr_gen.AddressIn.sin_addr.S_un.S_addr))
1463                           :netmask (ntohl
1464                                     (pref (pref p #>INTERFACE_INFO.iiNetmask)
1465                                        #>sockaddr_gen.AddressIn.sin_addr.S_un.S_addr))
1466                           :flags (pref p #>INTERFACE_INFO.iiFlags)
1467                           :address-family #$AF_INET)
1468                          interfaces)))
1469                (return interfaces)))))))
[12267]1470      (#_closesocket socket))))
[10865]1471
[10109]1472     
1473
1474
[6]1475(defloadvar *ip-interfaces* ())
1476
1477(defun ip-interfaces ()
1478  (or *ip-interfaces*
1479      (setq *ip-interfaces* (%get-ip-interfaces))))
1480
1481;;; This should presumably happen after a configuration change.
1482;;; How do we detect a configuration change ?
1483(defun %reset-ip-interfaces ()
1484  (setq *ip-interfaces* ()))
1485
1486;;; Return the first non-loopback interface that's up and whose address
1487;;; family is #$AF_INET.  If no such interface exists, return
1488;;; the loopback interface.
1489(defun primary-ip-interface ()
1490  (let* ((ifaces (ip-interfaces)))
1491    (or (find-if #'(lambda (i)
1492                     (and (eq #$AF_INET (ip-interface-address-family i))
[8240]1493                          (ip-interface-addr i)
[6]1494                          (let* ((flags (ip-interface-flags i)))
1495                            (and (not (logtest #$IFF_LOOPBACK flags))
1496                                 (logtest #$IFF_UP flags)))))
1497                 ifaces)
1498        (car ifaces))))
1499
1500(defun primary-ip-interface-address ()
1501  (let* ((iface (primary-ip-interface)))
1502    (if iface
1503      (ip-interface-addr iface)
1504      (error "Can't determine primary IP interface"))))
1505         
1506         
[423]1507(defmethod stream-io-error ((stream socket) errno where)
1508  (socket-error stream where errno))
Note: See TracBrowser for help on using the repository browser.