sockets/socket-methods.lisp

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