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

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

Lots of conditionalization for windows.

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