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 #.(foreign-type-size 'et:sockaddr-storage))
 205           (with-foreign-pointer (size #.(foreign-type-size :socklen))
 206             (setf (mem-ref size :socklen)
 207                   #.(foreign-type-size 'et: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 #.(foreign-type-size 'et:sockaddr-storage))
 250     (with-foreign-pointer (size #.(foreign-type-size :socklen))
 251       (setf (mem-ref size :socklen)
 252             #.(foreign-type-size 'et: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 #.(foreign-type-size 'et:sockaddr-un))
 262     (with-foreign-pointer (size #.(foreign-type-size :socklen))
 263       (setf (mem-ref size :socklen)
 264             #.(foreign-type-size 'et: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 #.(foreign-type-size 'et:sockaddr-storage))
 285     (with-foreign-pointer (size #.(foreign-type-size :socklen))
 286       (setf (mem-ref size :socklen)
 287             #.(foreign-type-size 'et: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 #.(foreign-type-size 'et:sockaddr-un))
 297     (with-foreign-pointer (size #.(foreign-type-size :socklen))
 298       (setf (mem-ref size :socklen)
 299             #.(foreign-type-size 'et: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
 321                #.(foreign-type-size 'et:sockaddr-in)))))
 322
 323 (defun bind-ipv6-address (fd address port)
 324   (with-foreign-object (sin6 'et:sockaddr-in6)
 325     (make-sockaddr-in6 sin6 address port)
 326     (with-socket-error-filter
 327       (et:bind fd sin6
 328                #.(foreign-type-size 'et:sockaddr-in6)))))
 329
 330 (defmethod bind-address ((socket internet-socket)
 331                          (address ipv4addr)
 332                          &key (port 0))
 333   (if (eql (socket-family socket) :ipv6)
 334       (bind-ipv6-address (socket-fd socket)
 335                          (map-ipv4-vector-to-ipv6 (name address))
 336                          port)
 337       (bind-ipv4-address (socket-fd socket) (name address) port))
 338   (values socket))
 339
 340 (defmethod bind-address ((socket internet-socket)
 341                          (address ipv6addr)
 342                          &key (port 0))
 343   (bind-ipv6-address (socket-fd socket) (name address) port)
 344   (values socket))
 345
 346 (defmethod bind-address :before ((socket local-socket)
 347                                  (address localaddr) &key)
 348   (when (typep socket 'active-socket)
 349     (error "You can't bind an active Unix socket.")))
 350
 351 (defmethod bind-address ((socket local-socket)
 352                          (address localaddr) &key)
 353   (with-foreign-object (sun 'et:sockaddr-un)
 354     (make-sockaddr-un sun (name address))
 355     (with-socket-error-filter
 356       (et:bind (socket-fd socket)
 357                sun
 358                #.(foreign-type-size 'et:sockaddr-un))))
 359   (values socket))
 360
 361 (defmethod bind-address :after ((socket socket)
 362                                 (address sockaddr) &key)
 363   (setf (slot-value socket 'bound) t))
 364
 365
 366 ;;;;;;;;;;;;;;
 367 ;;  LISTEN  ;;
 368 ;;;;;;;;;;;;;;
 369
 370 (defmethod socket-listen ((socket passive-socket)
 371                           &key (backlog (min *default-backlog-size*
 372                                              +max-backlog-size+)))
 373   (check-type backlog unsigned-byte "a non-negative integer")
 374   (with-socket-error-filter
 375     (et:listen (socket-fd socket) backlog))
 376   (setf (slot-value socket 'listening) t)
 377   (values socket))
 378
 379 (defmethod socket-listen ((socket active-socket)
 380                           &key backlog)
 381   (declare (ignore backlog))
 382   (error "You can't listen on active sockets."))
 383
 384
 385 ;;;;;;;;;;;;;;
 386 ;;  ACCEPT  ;;
 387 ;;;;;;;;;;;;;;
 388
 389 (defmethod accept-connection ((socket active-socket)
 390                               &key wait)
 391   (declare (ignore wait))
 392   (error "You can't accept connections on active sockets."))
 393
 394 (defmethod accept-connection ((socket passive-socket)
 395                               &key (wait t))
 396   (with-foreign-object (ss 'et:sockaddr-storage)
 397     (et:memset ss 0 #.(foreign-type-size 'et:sockaddr-storage))
 398     (with-foreign-pointer (size #.(foreign-type-size :socklen))
 399       (setf (mem-ref size :socklen)
 400             #.(foreign-type-size 'et:sockaddr-storage))
 401       (let (non-blocking-state
 402             client-fd)
 403         (with-socket-error-filter
 404           (handler-case
 405               (if wait
 406                   ;; do a "normal" accept
 407                   ;; Note: the socket may already be in non-blocking mode
 408                   (setf client-fd (et:accept (socket-fd socket)
 409                                              ss size))
 410                   ;; set the socket to non-blocking mode before calling accept()
 411                   ;; if there's no new connection return NIL
 412                   (unwind-protect
 413                        (progn
 414                          ;; saving the current non-blocking state
 415                          (setf non-blocking-state (socket-non-blocking socket))
 416                          ;; switch the socket to non-blocking mode
 417                          (setf (socket-non-blocking socket) t)
 418                          (setf client-fd (et:accept (socket-fd socket)
 419                                                     ss size)))
 420                     ;; restoring the socket's non-blocking state
 421                     (setf (socket-non-blocking socket) non-blocking-state)))
 422             ;; the socket is marked non-blocking and there's no new connection
 423             (et:unix-error-wouldblock (err)
 424               (declare (ignore err))
 425               (return-from accept-connection nil))))
 426
 427         (let ((client-socket
 428                ;; create the client socket object
 429                (make-instance (active-class socket)
 430                               :file-descriptor client-fd)))
 431           (return-from accept-connection client-socket))))))
 432
 433
 434 ;;;;;;;;;;;;;;;
 435 ;;  CONNECT  ;;
 436 ;;;;;;;;;;;;;;;
 437
 438 #+freebsd
 439 (defmethod connect :before ((socket active-socket)
 440                             sockaddr &key)
 441   (when *no-sigpipe*
 442     (set-socket-option socket :no-sigpipe :value t)))
 443
 444 (defun ipv4-connect (fd address port)
 445   (with-foreign-object (sin 'et:sockaddr-in)
 446     (make-sockaddr-in sin address port)
 447     (with-socket-error-filter
 448       (et:connect fd sin
 449                   #.(foreign-type-size 'et:sockaddr-in)))))
 450
 451 (defun ipv6-connect (fd address port)
 452   (with-foreign-object (sin6 'et:sockaddr-in6)
 453     (make-sockaddr-in6 sin6 address port)
 454     (with-socket-error-filter
 455       (et:connect fd sin6
 456                   (foreign-type-size 'et:sockaddr-in6)))))
 457
 458 (defmethod connect ((socket internet-socket)
 459                     (address ipv4addr) &key (port 0))
 460   (if (eql (socket-family socket) :ipv6)
 461       (ipv6-connect (socket-fd socket)
 462                     (map-ipv4-vector-to-ipv6 (name address))
 463                     port)
 464       (ipv4-connect (socket-fd socket) (name address) port))
 465   (values socket))
 466
 467 (defmethod connect ((socket internet-socket)
 468                     (address ipv6addr) &key (port 0))
 469   (ipv6-connect (socket-fd socket) (name address) port)
 470   (values socket))
 471
 472 (defmethod connect ((socket local-socket)
 473                     (address localaddr) &key)
 474   (with-foreign-object (sun 'et:sockaddr-un)
 475     (make-sockaddr-un sun (name address))
 476     (with-socket-error-filter
 477       (et:connect (socket-fd socket)
 478                   sun
 479                   #.(foreign-type-size 'et:sockaddr-un))))
 480   (values socket))
 481
 482 (defmethod connect ((socket passive-socket)
 483                     address &key)
 484   (error "You cannot connect passive sockets."))
 485
 486 (defmethod socket-connected-p ((socket socket))
 487   (unless (slot-boundp socket 'fd)
 488     (return-from socket-connected-p nil))
 489   (with-socket-error-filter
 490     (handler-case
 491         (with-foreign-object (ss 'et:sockaddr-storage)
 492           (et:memset ss 0 #.(foreign-type-size 'et:sockaddr-storage))
 493           (with-foreign-pointer (size #.(foreign-type-size :socklen))
 494             (setf (mem-ref size :socklen)
 495                   #.(foreign-type-size 'et:sockaddr-storage))
 496             (et:getpeername (socket-fd socket)
 497                             ss size)
 498             t))
 499       (et:unix-error-notconn (err)
 500         (declare (ignore err))
 501         nil))))
 502
 503
 504 ;;;;;;;;;;;;;;;;
 505 ;;  SHUTDOWN  ;;
 506 ;;;;;;;;;;;;;;;;
 507
 508 (defmethod shutdown ((socket active-socket) direction)
 509   (check-type direction (member :read :write :read-write)
 510               "valid direction specifier")
 511   (with-socket-error-filter
 512     (et:shutdown (socket-fd socket)
 513                  (ecase direction
 514                    (:read et:shut-rd)
 515                    (:write et:shut-wr)
 516                    (:read-write et:shut-rdwr))))
 517   (values socket))
 518
 519 (defmethod shutdown ((socket passive-socket) direction)
 520   (error "You cannot shut down passive sockets."))
 521
 522
 523 ;;;;;;;;;;;;
 524 ;;  SEND  ;;
 525 ;;;;;;;;;;;;
 526
 527 (defun normalize-send-buffer (buff vstart vend)
 528   (let ((start (or vstart 0))
 529         (end (if vend
 530                  (min vend (length buff))
 531                  (length buff))))
 532     (assert (<= start end))
 533     (etypecase buff
 534       ((simple-array ub8 (*)) (values buff start (- end start)))
 535       ((vector ub8) (values (coerce buff '(simple-array ub8 (*)))
 536                             start (- end start)))
 537       (string (values (coerce (flexi-streams:string-to-octets buff :external-format :latin1
 538                                                               :start start :end end)
 539                               '(simple-array ub8 (*)))
 540                       0 (- end start))))))
 541
 542 (defmethod socket-send :before ((buffer array)
 543                                 (socket active-socket)
 544                                 &key start end
 545                                 remote-address remote-port)
 546   (check-type start (or unsigned-byte null)
 547               "a non-negative value or NIL")
 548   (check-type end (or unsigned-byte null)
 549               "a non-negative value or NIL")
 550   (when (or remote-port remote-address)
 551     (check-type remote-address sockaddr "a network address")
 552     (check-type remote-port (unsigned-byte 16) "a valid IP port number")))
 553
 554 (defmethod socket-send ((buffer array)
 555                         (socket active-socket) &key start end
 556                         remote-address remote-port end-of-record
 557                         dont-route dont-wait (no-signal *no-sigpipe*)
 558                         out-of-band #+linux more #+linux confirm)
 559
 560   (let ((flags (logior (if end-of-record et:msg-eor 0)
 561                        (if dont-route et:msg-dontroute 0)
 562                        (if dont-wait  et:msg-dontwait 0)
 563                        (if no-signal  et:msg-nosignal 0)
 564                        (if out-of-band et:msg-oob 0)
 565                        #+linux (if more et:msg-more 0)
 566                        #+linux (if confirm et:msg-confirm 0))))
 567
 568     (when (and (ipv4-address-p remote-address)
 569                (eql (socket-family socket) :ipv6))
 570       (setf remote-address (map-ipv4-address->ipv6 remote-address)))
 571     (multiple-value-bind (buff start-offset bufflen)
 572         (normalize-send-buffer buffer start end)
 573       (with-foreign-object (ss 'et:sockaddr-storage)
 574         (et:memset ss 0 #.(foreign-type-size 'et:sockaddr-storage))
 575         (when remote-address
 576           (sockaddr->sockaddr-storage ss remote-address remote-port))
 577         (with-pointer-to-vector-data (buff-sap buff)
 578           (incf-pointer buff-sap start-offset)
 579           (with-socket-error-filter
 580             (return-from socket-send
 581               (et:sendto (socket-fd socket)
 582                          buff-sap bufflen
 583                          flags
 584                          (if remote-address ss (null-pointer))
 585                          (if remote-address #.(foreign-type-size 'et:sockaddr-storage) 0)))))))))
 586
 587 (defmethod socket-send (buffer (socket passive-socket) &key)
 588   (error "You cannot send data on a passive socket."))
 589
 590
 591 ;;;;;;;;;;;;
 592 ;;  RECV  ;;
 593 ;;;;;;;;;;;;
 594
 595 (defun normalize-receive-buffer (buff vstart vend)
 596   (let ((start (or vstart 0))
 597         (end (if vend
 598                  (min vend (length buff))
 599                  (length buff))))
 600     (assert (<= start end))
 601     (etypecase buff
 602       ((simple-array ub8 (*)) (values buff start (- end start)))
 603       (simple-base-string (values buff start (- end start))))))
 604
 605 (defmethod socket-receive :before ((buffer array)
 606                                    (socket active-socket)
 607                                    &key start end)
 608   (check-type start (or unsigned-byte null)
 609               "a non-negative value or NIL")
 610   (check-type end (or unsigned-byte null)
 611               "a non-negative value or NIL"))
 612
 613 (defmethod socket-receive ((buffer array)
 614                            (socket active-socket) &key start end
 615                            out-of-band peek wait-all
 616                            dont-wait (no-signal *no-sigpipe*))
 617
 618   (let ((flags (logior (if out-of-band et:msg-oob 0)
 619                        (if peek        et:msg-peek 0)
 620                        (if wait-all    et:msg-waitall 0)
 621                        (if dont-wait   et:msg-dontwait 0)
 622                        (if no-signal   et:msg-nosignal 0)))
 623         bytes-received)
 624
 625     (multiple-value-bind (buff start-offset bufflen)
 626         (normalize-receive-buffer buffer start end)
 627       (with-foreign-object (ss 'et:sockaddr-storage)
 628         (et:memset ss 0 #.(foreign-type-size 'et:sockaddr-storage))
 629         (with-foreign-pointer (size #.(foreign-type-size :socklen))
 630           (setf (mem-ref size :socklen)
 631                 #.(foreign-type-size 'et:sockaddr-storage))
 632           (with-pointer-to-vector-data (buff-sap buff)
 633             (incf-pointer buff-sap start-offset)
 634             (with-socket-error-filter
 635               (setf bytes-received
 636                     (et:recvfrom (socket-fd socket)
 637                                  buff-sap bufflen
 638                                  flags
 639                                  ss size)))))
 640
 641         (return-from socket-receive
 642           ;; when socket is a datagram socket
 643           ;; return the sender's address as 3rd value
 644           (if (typep socket 'datagram-socket)
 645               (multiple-value-bind (remote-address remote-port)
 646                   (sockaddr-storage->sockaddr ss)
 647                 (values buffer bytes-received remote-address remote-port))
 648               (values buffer bytes-received)))))))
 649
 650 (defmethod socket-receive (buffer (socket passive-socket) &key)
 651   (error "You cannot receive data from a passive socket."))
 652
 653
 654 ;;
 655 ;; Only for datagram sockets
 656 ;;
 657
 658 (defmethod unconnect :before ((socket active-socket))
 659   (unless (typep socket 'datagram-socket)
 660     (error "You can only unconnect active datagram sockets.")))
 661
 662 (defmethod unconnect ((socket datagram-socket))
 663   (with-socket-error-filter
 664     (with-foreign-object (sin 'et:sockaddr-in)
 665       (et:memset sin 0 #.(foreign-type-size 'et:sockaddr-in))
 666       (setf (foreign-slot-value sin 'et:sockaddr-in 'et:address) et:af-unspec)
 667       (et:connect (socket-fd socket)
 668                   sin
 669                   #.(foreign-type-size 'et:sockaddr-in)))))