source: branches/ia32/level-1/l1-sockets.lisp

Last change on this file was 9717, checked in by rme, 11 years ago

verify-socket-buffer: buf type-checking for x8632.

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