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

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

More changes to ease Windows bootstrapping - error returns, socket fds
vs handles, etc.

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