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

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

%GET-IP-INTERFACES for Solaris; very different from other versions.

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