sockets/socket-methods.lisp

   1 ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
   2
   3 ;;   Copyright (C) 2006, 2007 Stelian Ionescu
   4 ;;
   5 ;;   This code is free software; you can redistribute it and/or
   6 ;;   modify it under the terms of the version 2.1 of
   7 ;;   the GNU Lesser General Public License as published by
   8 ;;   the Free Software Foundation, as clarified by the
   9 ;;   preamble found here:
  10 ;;       http://opensource.franz.com/preamble.html
  11 ;;
  12 ;;   This program is distributed in the hope that it will be useful,
  13 ;;   but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;   GNU General Public License for more details.
  16 ;;
  17 ;;   You should have received a copy of the GNU Lesser General
  18 ;;   Public License along with this library; if not, write to the
  19 ;;   Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
  20 ;;   Boston, MA 02110-1301, USA
  21
  22 (in-package :net.sockets)
  23
  24 (defparameter *socket-type-map*
  25   '(((:ipv4  :stream   :active  :default) . socket-stream-internet-active)
  26     ((:ipv6  :stream   :active  :default) . socket-stream-internet-active)
  27     ((:ipv4  :stream   :passive :default) . socket-stream-internet-passive)
  28     ((:ipv6  :stream   :passive :default) . socket-stream-internet-passive)
  29     ((:local :stream   :active  :default) . socket-stream-local-active)
  30     ((:local :stream   :passive :default) . socket-stream-local-passive)
  31     ((:local :datagram :active  :default) . socket-datagram-local-active)
  32     ((:ipv4  :datagram :active  :default) . socket-datagram-internet-active)
  33     ((:ipv6  :datagram :active  :default) . socket-datagram-internet-active)))
  34
  35 (defun select-socket-type (family type connect protocol)
  36   (or (cdr (assoc (list family type connect protocol) *socket-type-map*
  37                   :test #'equal))
  38       (error "No socket class found !!")))
  39
  40
  41 ;;;;;;;;;;;;;;;;;;;;;;;;;
  42 ;;  SHARED-INITIALIZE  ;;
  43 ;;;;;;;;;;;;;;;;;;;;;;;;;
  44
  45 (defun translate-make-socket-keywords-to-constants (family type protocol)
  46   (let ((sf (ecase family
  47               (:ipv4  et:af-inet)
  48               (:ipv6  et:af-inet6)
  49               (:local et:af-local)))
  50         (st (ecase type
  51               (:stream   et:sock-stream)
  52               (:datagram et:sock-dgram)))
  53         (sp (cond
  54               ((integerp protocol) protocol)
  55               ((eql protocol :default) 0)
  56               ((keywordp protocol)
  57                (protocol-number
  58                 (get-protocol-by-name (string-downcase
  59                                        (string protocol))))))))
  60     (values sf st sp)))
  61
  62 (defmethod shared-initialize :after ((socket socket) slot-names
  63                                      &key file-descriptor family
  64                                      type (protocol :default))
  65   (when (socket-open-p socket)
  66     (socket-close socket))
  67   (with-slots (fd (fam family) (proto protocol)) socket
  68     (multiple-value-bind (sf st sp)
  69         (translate-make-socket-keywords-to-constants family type protocol)
  70       (if file-descriptor
  71           (setf fd file-descriptor)
  72           (setf fd (with-socket-error-filter
  73                      (et:socket sf st sp))))
  74       (setf fam family
  75             proto protocol))))
  76
  77 ;; TODO: find out how to make an FD-STREAM on other implementations
  78 (defun make-fd-stream (fd)
  79   (check-type fd unsigned-byte)
  80   #+sbcl
  81   (sb-sys:make-fd-stream fd
  82                          :name (format nil "Socket stream, fd: ~A" fd)
  83                          :input t :output t :buffering :full :dual-channel-p t
  84                          :element-type :default :auto-close nil)
  85   #+cmucl
  86   (system:make-fd-stream fd
  87                          :name (format nil "Socket stream, fd: ~A" fd)
  88                          :input t :output t :buffering :full
  89                          :binary-stream-p nil :auto-close nil))
  90
  91 (defmethod shared-initialize :after ((socket stream-socket) slot-names &key)
  92   (setf (slot-value socket 'lisp-stream)
  93         (make-fd-stream (socket-fd socket))))
  94
  95 (defmethod socket-type ((socket stream-socket))
  96   :stream)
  97
  98 (defmethod socket-type ((socket datagram-socket))
  99   :datagram)
 100
 101
 102 ;;;;;;;;;;;;;;;;;;;;
 103 ;;  PRINT-OBJECT  ;;
 104 ;;;;;;;;;;;;;;;;;;;;
 105
 106 (defmethod print-object ((socket socket-stream-internet-active) stream)
 107   (print-unreadable-object (socket stream :type nil :identity t)
 108     (format stream "internet stream socket" )
 109     (if (socket-connected-p socket)
 110         (multiple-value-bind (addr port) (remote-name socket)
 111           (format stream " connected to ~A/~A"
 112                   (sockaddr->presentation addr) port))
 113         (if (slot-boundp socket 'fd)
 114             (format stream ", unconnected")
 115             (format stream ", closed")))))
 116
 117 (defmethod print-object ((socket socket-stream-internet-passive) stream)
 118   (print-unreadable-object (socket stream :type nil :identity t)
 119     (format stream "internet stream socket" )
 120     (if (socket-bound-p socket)
 121         (multiple-value-bind (addr port) (local-name socket)
 122           (format stream " ~A ~A/~A"
 123                   (if (socket-listening-p socket)
 124                       "waiting for connections @"
 125                       "bound to")
 126                   (sockaddr->presentation addr) port))
 127         (if (slot-boundp socket 'fd)
 128             (format stream ", unbound")
 129             (format stream ", closed")))))
 130
 131 (defmethod print-object ((socket socket-stream-local-active) stream)
 132   (print-unreadable-object (socket stream :type nil :identity t)
 133     (format stream "local stream socket" )
 134     (if (socket-connected-p socket)
 135         (format stream " connected")
 136         (if (slot-boundp socket 'fd)
 137             (format stream ", unconnected")
 138             (format stream ", closed")))))
 139
 140 (defmethod print-object ((socket socket-stream-local-passive) stream)
 141   (print-unreadable-object (socket stream :type nil :identity t)
 142     (format stream "local stream socket" )
 143     (if (socket-bound-p socket)
 144         (format stream " ~A ~A"
 145                 (if (socket-listening-p socket)
 146                     "waiting for connections @"
 147                     "bound to")
 148                 (sockaddr->presentation (socket-address socket)))
 149         (if (slot-boundp socket 'fd)
 150             (format stream ", unbound")
 151             (format stream ", closed")))))
 152
 153 (defmethod print-object ((socket socket-datagram-local-active) stream)
 154   (print-unreadable-object (socket stream :type nil :identity t)
 155     (format stream "local datagram socket" )
 156     (if (socket-connected-p socket)
 157         (format stream " connected")
 158         (if (slot-boundp socket 'fd)
 159             (format stream ", unconnected")
 160             (format stream ", closed")))))
 161
 162 (defmethod print-object ((socket socket-datagram-internet-active) stream)
 163   (print-unreadable-object (socket stream :type nil :identity t)
 164     (format stream "internet stream socket" )
 165     (if (socket-connected-p socket)
 166         (multiple-value-bind (addr port) (remote-name socket)
 167           (format stream " connected to ~A/~A"
 168                   (sockaddr->presentation addr) port))
 169         (if (slot-boundp socket 'fd)
 170             (format stream ", unconnected")
 171             (format stream ", closed")))))
 172
 173
 174 ;;;;;;;;;;;;;
 175 ;;  CLOSE  ;;
 176 ;;;;;;;;;;;;;
 177
 178 (defmethod socket-close progn ((socket socket))
 179   (when (slot-boundp socket 'fd)
 180     (with-socket-error-filter
 181       (et:close (socket-fd socket))))
 182   (mapc #'(lambda (slot)
 183             (slot-makunbound socket slot))
 184         '(fd family protocol))
 185   (values socket))
 186
 187 (defmethod socket-close progn ((socket stream-socket))
 188   (slot-makunbound socket 'lisp-stream))
 189
 190 (defmethod socket-close progn ((socket passive-socket))
 191   (slot-makunbound socket 'listening))
 192
 193 (defmethod socket-open-p ((socket socket))
 194   (unless (slot-boundp socket 'fd)
 195     (return-from socket-open-p nil))
 196   (with-socket-error-filter
 197     (handler-case
 198         (with-foreign-object (ss 'et:sockaddr-storage)
 199           (et:bzero ss et:size-of-sockaddr-storage)
 200           (with-foreign-pointer (size et:size-of-socklen)
 201             (setf (mem-ref size :socklen)
 202                   et:size-of-sockaddr-storage)
 203             (et:getsockname (socket-fd socket)
 204                             ss size)
 205             t))
 206       (unix-error (err)
 207         (case (error-identifier err)
 208           ((:ebadf
 209             #+freebsd :econnreset)
 210            nil)
 211           ;; some other error
 212           (otherwise (error err)))))))
 213
 214
 215 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 216 ;;  get and set O_NONBLOCK  ;;
 217 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 218
 219 (defmethod socket-non-blocking ((socket socket))
 220   (with-slots (fd) socket
 221     (let ((current-flags (with-socket-error-filter
 222                            (et:fcntl fd et:f-getfl))))
 223       (logtest et:o-nonblock current-flags))))
 224
 225 (defmethod (setf socket-non-blocking) (value (socket socket))
 226   (check-type value boolean "a boolean value")
 227   (with-slots (fd) socket
 228     (with-socket-error-filter
 229       (let* ((current-flags (et:fcntl fd et:f-getfl))
 230              (new-flags (if value
 231                             (logior current-flags et:o-nonblock)
 232                             (logandc2 current-flags et:o-nonblock))))
 233         (when (/= new-flags current-flags)
 234           (et:fcntl fd et:f-setfl new-flags)))))
 235   (values value))
 236
 237
 238 ;;;;;;;;;;;;;;;;;;;
 239 ;;  GETSOCKNAME  ;;
 240 ;;;;;;;;;;;;;;;;;;;
 241
 242 (defmethod local-name ((socket internet-socket))
 243   (with-foreign-object (ss 'et:sockaddr-storage)
 244     (et:bzero ss et:size-of-sockaddr-storage)
 245     (with-foreign-pointer (size et:size-of-socklen)
 246       (setf (mem-ref size :socklen)
 247             et:size-of-sockaddr-storage)
 248       (with-socket-error-filter
 249         (et:getsockname (socket-fd socket)
 250                         ss size))
 251       (return-from local-name
 252         (sockaddr-storage->sockaddr ss)))))
 253
 254 (defmethod local-name ((socket local-socket))
 255   (with-foreign-object (sun 'et:sockaddr-un)
 256     (et:bzero sun et:size-of-sockaddr-un)
 257     (with-foreign-pointer (size et:size-of-socklen)
 258       (setf (mem-ref size :socklen)
 259             et:size-of-sockaddr-storage)
 260       (with-socket-error-filter
 261         (et:getsockname (socket-fd socket)
 262                         sun size))
 263       (return-from local-name
 264         (sockaddr-un->sockaddr sun)))))
 265
 266 (defmethod socket-address ((socket socket))
 267   (nth-value 0 (local-name socket)))
 268
 269 (defmethod socket-port ((socket internet-socket))
 270   (nth-value 1 (local-name socket)))
 271
 272
 273 ;;;;;;;;;;;;;;;;;;;
 274 ;;  GETPEERNAME  ;;
 275 ;;;;;;;;;;;;;;;;;;;
 276
 277 (defmethod remote-name ((socket internet-socket))
 278   (with-foreign-object (ss 'et:sockaddr-storage)
 279     (et:bzero ss et:size-of-sockaddr-storage)
 280     (with-foreign-pointer (size et:size-of-socklen)
 281       (setf (mem-ref size :socklen)
 282             et:size-of-sockaddr-storage)
 283       (with-socket-error-filter
 284         (et:getpeername (socket-fd socket)
 285                         ss size))
 286       (return-from remote-name
 287         (sockaddr-storage->sockaddr ss)))))
 288
 289 (defmethod remote-name ((socket local-socket))
 290   (with-foreign-object (sun 'et:sockaddr-un)
 291     (et:bzero sun et:size-of-sockaddr-un)
 292     (with-foreign-pointer (size et:size-of-socklen)
 293       (setf (mem-ref size :socklen)
 294             et:size-of-sockaddr-storage)
 295       (with-socket-error-filter
 296         (et:getpeername (socket-fd socket)
 297                         sun size))
 298       (return-from remote-name
 299         (sockaddr-un->sockaddr sun)))))
 300
 301
 302 ;;;;;;;;;;;;
 303 ;;  BIND  ;;
 304 ;;;;;;;;;;;;
 305
 306 (defmethod bind-address :before ((socket internet-socket)
 307                                  address &key (reuse-address t))
 308   (when reuse-address
 309     (set-socket-option socket :reuse-address :value t)))
 310
 311 (defun bind-ipv4-address (fd address port)
 312   (with-foreign-object (sin 'et:sockaddr-in)
 313     (make-sockaddr-in sin address port)
 314     (with-socket-error-filter
 315       (et:bind fd sin et:size-of-sockaddr-in))))
 316
 317 (defun bind-ipv6-address (fd address port)
 318   (with-foreign-object (sin6 'et:sockaddr-in6)
 319     (make-sockaddr-in6 sin6 address port)
 320     (with-socket-error-filter
 321       (et:bind fd sin6 et:size-of-sockaddr-in6))))
 322
 323 (defmethod bind-address ((socket internet-socket)
 324                          (address ipv4addr)
 325                          &key (port 0))
 326   (if (eql (socket-family socket) :ipv6)
 327       (bind-ipv6-address (socket-fd socket)
 328                          (map-ipv4-vector-to-ipv6 (name address))
 329                          port)
 330       (bind-ipv4-address (socket-fd socket) (name address) port))
 331   (values socket))
 332
 333 (defmethod bind-address ((socket internet-socket)
 334                          (address ipv6addr)
 335                          &key (port 0))
 336   (bind-ipv6-address (socket-fd socket) (name address) port)
 337   (values socket))
 338
 339 (defmethod bind-address :before ((socket local-socket)
 340                                  (address localaddr) &key)
 341   (when (typep socket 'active-socket)
 342     (error "You can't bind an active Unix socket.")))
 343
 344 (defmethod bind-address ((socket local-socket)
 345                          (address localaddr) &key)
 346   (with-foreign-object (sun 'et:sockaddr-un)
 347     (make-sockaddr-un sun (name address))
 348     (with-socket-error-filter
 349       (et:bind (socket-fd socket) sun et:size-of-sockaddr-un)))
 350   (values socket))
 351
 352 (defmethod bind-address :after ((socket socket)
 353                                 (address sockaddr) &key)
 354   (setf (slot-value socket 'bound) t))
 355
 356
 357 ;;;;;;;;;;;;;;
 358 ;;  LISTEN  ;;
 359 ;;;;;;;;;;;;;;
 360
 361 (defmethod socket-listen ((socket passive-socket)
 362                           &key (backlog (min *default-backlog-size*
 363                                              +max-backlog-size+)))
 364   (check-type backlog unsigned-byte "a non-negative integer")
 365   (with-socket-error-filter
 366     (et:listen (socket-fd socket) backlog))
 367   (setf (slot-value socket 'listening) t)
 368   (values socket))
 369
 370 (defmethod socket-listen ((socket active-socket)
 371                           &key backlog)
 372   (declare (ignore backlog))
 373   (error "You can't listen on active sockets."))
 374
 375
 376 ;;;;;;;;;;;;;;
 377 ;;  ACCEPT  ;;
 378 ;;;;;;;;;;;;;;
 379
 380 (defmethod accept-connection ((socket active-socket)
 381                               &key wait)
 382   (declare (ignore wait))
 383   (error "You can't accept connections on active sockets."))
 384
 385 (defmethod accept-connection ((socket passive-socket)
 386                               &key (wait t))
 387   (with-foreign-object (ss 'et:sockaddr-storage)
 388     (et:bzero ss et:size-of-sockaddr-storage)
 389     (with-foreign-pointer (size et:size-of-socklen)
 390       (setf (mem-ref size :socklen)
 391             et:size-of-sockaddr-storage)
 392       (let (non-blocking-state
 393             client-fd)
 394         (with-socket-error-filter
 395           (handler-case
 396               (if wait
 397                   ;; do a "normal" accept
 398                   ;; Note: the socket may already be in non-blocking mode
 399                   (setf client-fd (et:accept (socket-fd socket)
 400                                              ss size))
 401                   ;; set the socket to non-blocking mode before calling accept()
 402                   ;; if there's no new connection return NIL
 403                   (unwind-protect
 404                        (progn
 405                          ;; saving the current non-blocking state
 406                          (setf non-blocking-state (socket-non-blocking socket))
 407                          ;; switch the socket to non-blocking mode
 408                          (setf (socket-non-blocking socket) t)
 409                          (setf client-fd (et:accept (socket-fd socket)
 410                                                     ss size)))
 411                     ;; restoring the socket's non-blocking state
 412                     (setf (socket-non-blocking socket) non-blocking-state)))
 413             ;; the socket is marked non-blocking and there's no new connection
 414             (et:unix-error-wouldblock (err)
 415               (declare (ignore err))
 416               (return-from accept-connection nil))))
 417
 418         (let ((client-socket
 419                ;; create the client socket object
 420                (make-instance (active-class socket)
 421                               :file-descriptor client-fd)))
 422           (return-from accept-connection client-socket))))))
 423
 424
 425 ;;;;;;;;;;;;;;;
 426 ;;  CONNECT  ;;
 427 ;;;;;;;;;;;;;;;
 428
 429 #+freebsd
 430 (defmethod connect :before ((socket active-socket)
 431                             sockaddr &key)
 432   (when *no-sigpipe*
 433     (set-socket-option socket :no-sigpipe :value t)))
 434
 435 (defun ipv4-connect (fd address port)
 436   (with-foreign-object (sin 'et:sockaddr-in)
 437     (make-sockaddr-in sin address port)
 438     (with-socket-error-filter
 439       (et:connect fd sin et:size-of-sockaddr-in))))
 440
 441 (defun ipv6-connect (fd address port)
 442   (with-foreign-object (sin6 'et:sockaddr-in6)
 443     (make-sockaddr-in6 sin6 address port)
 444     (with-socket-error-filter
 445       (et:connect fd sin6 et:size-of-sockaddr-in6))))
 446
 447 (defmethod connect ((socket internet-socket)
 448                     (address ipv4addr) &key (port 0))
 449   (if (eql (socket-family socket) :ipv6)
 450       (ipv6-connect (socket-fd socket)
 451                     (map-ipv4-vector-to-ipv6 (name address))
 452                     port)
 453       (ipv4-connect (socket-fd socket) (name address) port))
 454   (values socket))
 455
 456 (defmethod connect ((socket internet-socket)
 457                     (address ipv6addr) &key (port 0))
 458   (ipv6-connect (socket-fd socket) (name address) port)
 459   (values socket))
 460
 461 (defmethod connect ((socket local-socket)
 462                     (address localaddr) &key)
 463   (with-foreign-object (sun 'et:sockaddr-un)
 464     (make-sockaddr-un sun (name address))
 465     (with-socket-error-filter
 466       (et:connect (socket-fd socket) sun et:size-of-sockaddr-un)))
 467   (values socket))
 468
 469 (defmethod connect ((socket passive-socket)
 470                     address &key)
 471   (error "You cannot connect passive sockets."))
 472
 473 (defmethod socket-connected-p ((socket socket))
 474   (unless (slot-boundp socket 'fd)
 475     (return-from socket-connected-p nil))
 476   (with-socket-error-filter
 477     (handler-case
 478         (with-foreign-object (ss 'et:sockaddr-storage)
 479           (et:bzero ss et:size-of-sockaddr-storage)
 480           (with-foreign-pointer (size et:size-of-socklen)
 481             (setf (mem-ref size :socklen)
 482                   et:size-of-sockaddr-storage)
 483             (et:getpeername (socket-fd socket)
 484                             ss size)
 485             t))
 486       (et:unix-error-notconn (err)
 487         (declare (ignore err))
 488         nil))))
 489
 490
 491 ;;;;;;;;;;;;;;;;
 492 ;;  SHUTDOWN  ;;
 493 ;;;;;;;;;;;;;;;;
 494
 495 (defmethod shutdown ((socket active-socket) direction)
 496   (check-type direction (member :read :write :read-write)
 497               "valid direction specifier")
 498   (with-socket-error-filter
 499     (et:shutdown (socket-fd socket)
 500                  (ecase direction
 501                    (:read et:shut-rd)
 502                    (:write et:shut-wr)
 503                    (:read-write et:shut-rdwr))))
 504   (values socket))
 505
 506 (defmethod shutdown ((socket passive-socket) direction)
 507   (error "You cannot shut down passive sockets."))
 508
 509
 510 ;;;;;;;;;;;;
 511 ;;  SEND  ;;
 512 ;;;;;;;;;;;;
 513
 514 (defun normalize-send-buffer (buff vstart vend)
 515   (let ((start (or vstart 0))
 516         (end (if vend
 517                  (min vend (length buff))
 518                  (length buff))))
 519     (assert (<= start end))
 520     (etypecase buff
 521       ((simple-array ub8 (*)) (values buff start (- end start)))
 522       ((vector ub8) (values (coerce buff '(simple-array ub8 (*)))
 523                             start (- end start)))
 524       (string (values (coerce (flexi-streams:string-to-octets buff :external-format :iso-8859-1
 525                                                               :start start :end end)
 526                               '(simple-array ub8 (*)))
 527                       0 (- end start))))))
 528
 529 (defmethod socket-send :before ((buffer array)
 530                                 (socket active-socket)
 531                                 &key start end
 532                                 remote-address remote-port)
 533   (check-type start (or unsigned-byte null)
 534               "a non-negative value or NIL")
 535   (check-type end (or unsigned-byte null)
 536               "a non-negative value or NIL")
 537   (when (or remote-port remote-address)
 538     (check-type remote-address sockaddr "a network address")
 539     (check-type remote-port (unsigned-byte 16) "a valid IP port number")))
 540
 541 (defmethod socket-send ((buffer array)
 542                         (socket active-socket) &key start end
 543                         remote-address remote-port end-of-record
 544                         dont-route dont-wait (no-signal *no-sigpipe*)
 545                         out-of-band #+linux more #+linux confirm)
 546
 547   (let ((flags (logior (if end-of-record et:msg-eor 0)
 548                        (if dont-route et:msg-dontroute 0)
 549                        (if dont-wait  et:msg-dontwait 0)
 550                        (if no-signal  et:msg-nosignal 0)
 551                        (if out-of-band et:msg-oob 0)
 552                        #+linux (if more et:msg-more 0)
 553                        #+linux (if confirm et:msg-confirm 0))))
 554
 555     (when (and (ipv4-address-p remote-address)
 556                (eql (socket-family socket) :ipv6))
 557       (setf remote-address (map-ipv4-address->ipv6 remote-address)))
 558     (multiple-value-bind (buff start-offset bufflen)
 559         (normalize-send-buffer buffer start end)
 560       (with-foreign-object (ss 'et:sockaddr-storage)
 561         (et:bzero ss et:size-of-sockaddr-storage)
 562         (when remote-address
 563           (sockaddr->sockaddr-storage ss remote-address remote-port))
 564         (with-pointer-to-vector-data (buff-sap buff)
 565           (incf-pointer buff-sap start-offset)
 566           (with-socket-error-filter
 567             (return-from socket-send
 568               (et:sendto (socket-fd socket)
 569                          buff-sap bufflen
 570                          flags
 571                          (if remote-address ss (null-pointer))
 572                          (if remote-address et:size-of-sockaddr-storage 0)))))))))
 573
 574 (defmethod socket-send (buffer (socket passive-socket) &key)
 575   (error "You cannot send data on a passive socket."))
 576
 577
 578 ;;;;;;;;;;;;
 579 ;;  RECV  ;;
 580 ;;;;;;;;;;;;
 581
 582 (defun normalize-receive-buffer (buff vstart vend)
 583   (let ((start (or vstart 0))
 584         (end (if vend
 585                  (min vend (length buff))
 586                  (length buff))))
 587     (assert (<= start end))
 588     (etypecase buff
 589       ((simple-array ub8 (*)) (values buff start (- end start)))
 590       (simple-base-string (values buff start (- end start))))))
 591
 592 (defmethod socket-receive :before ((buffer array)
 593                                    (socket active-socket)
 594                                    &key start end)
 595   (check-type start (or unsigned-byte null)
 596               "a non-negative value or NIL")
 597   (check-type end (or unsigned-byte null)
 598               "a non-negative value or NIL"))
 599
 600 (defmethod socket-receive ((buffer array)
 601                            (socket active-socket) &key start end
 602                            out-of-band peek wait-all
 603                            dont-wait (no-signal *no-sigpipe*))
 604
 605   (let ((flags (logior (if out-of-band et:msg-oob 0)
 606                        (if peek        et:msg-peek 0)
 607                        (if wait-all    et:msg-waitall 0)
 608                        (if dont-wait   et:msg-dontwait 0)
 609                        (if no-signal   et:msg-nosignal 0)))
 610         bytes-received)
 611
 612     (multiple-value-bind (buff start-offset bufflen)
 613         (normalize-receive-buffer buffer start end)
 614       (with-foreign-object (ss 'et:sockaddr-storage)
 615         (et:bzero ss et:size-of-sockaddr-storage)
 616         (with-foreign-pointer (size et:size-of-socklen)
 617           (setf (mem-ref size :socklen)
 618                 et:size-of-sockaddr-storage)
 619           (with-pointer-to-vector-data (buff-sap buff)
 620             (incf-pointer buff-sap start-offset)
 621             (with-socket-error-filter
 622               (setf bytes-received
 623                     (et:recvfrom (socket-fd socket)
 624                                  buff-sap bufflen
 625                                  flags
 626                                  ss size)))))
 627
 628         (return-from socket-receive
 629           ;; when socket is a datagram socket
 630           ;; return the sender's address as 3rd value
 631           (if (typep socket 'datagram-socket)
 632               (multiple-value-bind (remote-address remote-port)
 633                   (sockaddr-storage->sockaddr ss)
 634                 (values buffer bytes-received remote-address remote-port))
 635               (values buffer bytes-received)))))))
 636
 637 (defmethod socket-receive (buffer (socket passive-socket) &key)
 638   (error "You cannot receive data from a passive socket."))
 639
 640
 641 ;;
 642 ;; Only for datagram sockets
 643 ;;
 644
 645 (defmethod unconnect :before ((socket active-socket))
 646   (unless (typep socket 'datagram-socket)
 647     (error "You can only unconnect active datagram sockets.")))
 648
 649 (defmethod unconnect ((socket datagram-socket))
 650   (with-socket-error-filter
 651     (with-foreign-object (sin 'et:sockaddr-in)
 652       (et:bzero sin et:size-of-sockaddr-in)
 653       (setf (foreign-slot-value sin 'et:sockaddr-in 'et:addr) et:af-unspec)
 654       (et:connect (socket-fd socket) sin et:size-of-sockaddr-in))))