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

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

Try again to use ff-calls, not syscalls (now that the transparent-union
dust has settled a bit.)

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