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

Last change on this file since 10877 was 10877, checked in by gb, 11 years ago

in C_SOCKET_1: get errno before calling #_CloseHandle if allocating an
fd for the socket fails, just in case.

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