Changeset 768


Ignore:
Timestamp:
Apr 12, 2004, 7:29:13 PM (16 years ago)
Author:
gb
Message:

Erik Pearson's SOCKET-ERROR changes/fixes.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/ccl/level-1/l1-sockets.lisp

    r440 r768  
    117117  ((code :initarg :code :reader socket-error-code)
    118118   (identifier :initform :unknown :initarg :identifier :reader socket-error-identifier)
    119    (situation :initarg :situation :reader socket-error-situation)))
     119   (Situation :initarg :situation :reader socket-error-situation)))
     120
     121(define-condition socket-creation-error (simple-error)
     122  ((code :initarg :code :reader socket-creation-error-code)
     123   (identifier :initform :unknown :initarg :identifier :reader socket-creationg-error-identifier)
     124   (situation :initarg :situation :reader socket-creation-error-situation)))
    120125
    121126(defvar *socket-error-identifiers*
     
    155160
    156161(defun socket-error (stream where errno &optional nameserver-p)
     162  "Creates and signals (via error) one of two socket error
     163conditions, based on the state of the arguments."
    157164  (when (< errno 0)
    158165    (setq errno (- errno)))
     
    171178                                                (%strerror errno))
    172179                                              errno stream where)))
    173     (error "~a (error #~d) in ~a"
    174            (if nameserver-p
    175              (%hstrerror errno)
    176              (%strerror errno))
    177            errno where)))
     180    (error (make-condition 'socket-creation-error
     181                           :code errno
     182                           :identifier (getf *socket-error-identifiers* errno :unknown)
     183                           :situation where
     184                           ;; TODO: this is a constant arg, there is a way to put this
     185                           ;; in the class definition, just need to remember how...
     186                           :format-control "~a (error #~d) on ~s in ~a"
     187                           :format-arguments (list
     188                                              (if nameserver-p
     189                                                (%hstrerror errno)
     190                                                (%strerror errno))
     191                                              errno stream where)))))
    178192   
    179193
     
    324338         (path-from-unix-address addr))))
    325339
    326          
    327 
    328 (defun remote-socket-info (fd type)
    329   (and fd
    330        (rlet ((sockaddr :sockaddr_in)
    331               (namelen :signed))
    332              (setf (pref namelen :signed) (record-length :sockaddr_in))
    333              (let ((err (c_getpeername fd sockaddr namelen)))
    334                (cond ((eql err (- #$ENOTCONN)) nil)
    335                      ((< err 0) (socket-error "getpeername" err))
    336                      (t
    337                       (when (= #$AF_INET (pref sockaddr :sockaddr_in.sin_family))
    338                         (ecase type
    339                           (:host (#_ntohl (pref sockaddr :sockaddr_in.sin_addr.s_addr)))
    340                           (:port (#_ntohs (pref sockaddr :sockaddr_in.sin_port)))))))))))
    341 
    342 (defun remote-socket-filename (fd)
    343   (and fd
    344        (rlet ((addr :sockaddr_un)
    345               (namelen :signed))
    346          (setf (pref namelen :signed) (record-length :sockaddr_un))
    347          (let* ((err (c_getsockname fd addr namelen)))
    348            (cond ((eql err (- #$ENOTCONN)) nil)
    349                  ((< err 0) (socket-error "getpeername" err))
    350                  (t (path-from-unix-address addr)))))))
     340(defmacro with-if ((var expr) &body body)
     341  `(let ((,var ,expr))
     342     (if ,var
     343         (progn
     344           ,@body))))     
     345
     346(defun remote-socket-info (socket type)
     347  (with-if (fd (socket-device socket))
     348    (rlet ((sockaddr :sockaddr_in)
     349           (namelen :signed))
     350          (setf (pref namelen :signed) (record-length :sockaddr_in))
     351          (let ((err (c_getpeername fd sockaddr namelen)))
     352            (cond ((eql err (- #$ENOTCONN)) nil)
     353                  ((< err 0) (socket-error socket "getpeername" err))
     354                  (t
     355                   (when (= #$AF_INET (pref sockaddr :sockaddr_in.sin_family))
     356                     (ecase type
     357                       (:host (#_ntohl (pref sockaddr :sockaddr_in.sin_addr.s_addr)))
     358                       (:port (#_ntohs (pref sockaddr :sockaddr_in.sin_port)))))))))))
     359
     360(defun remote-socket-filename (socket)
     361  (with-if (fd (socket-device socket))
     362    (rlet ((addr :sockaddr_un)
     363           (namelen :signed))
     364          (setf (pref namelen :signed) (record-length :sockaddr_un))
     365          (let* ((err (c_getsockname fd addr namelen)))
     366            (cond ((eql err (- #$ENOTCONN)) nil)
     367                  ((< err 0) (socket-error socket "getpeername" err))
     368                  (t (path-from-unix-address addr)))))))
    351369
    352370(defmethod LOCAL-PORT ((socket socket))
    353   (local-socket-info (socket-device socket) :port socket))
     371  (local-socket-info socket :port socket))
    354372
    355373(defmethod LOCAL-HOST ((socket socket))
    356   (local-socket-info (socket-device socket) :host socket))
     374  (local-socket-info socket :host socket))
    357375
    358376(defmethod LOCAL-FILENAME ((socket socket))
    359   (local-socket-filename (socket-device socket) socket))
     377  (local-socket-filename socket))
    360378
    361379;; Returns NIL if socket is not connected
    362380(defmethod REMOTE-HOST ((socket socket))
    363   (remote-socket-info (socket-device socket) :host))
     381  (remote-socket-info socket :host))
    364382
    365383(defmethod REMOTE-PORT ((socket socket))
    366   (remote-socket-info (socket-device socket) :port))
     384  (remote-socket-info socket :port))
    367385
    368386(defmethod REMOTE-FILENAME ((socket socket))
    369   (remote-socket-filename (socket-device socket)))
     387  (remote-socket-filename socket))
    370388 
    371 (defun set-socket-options (fd &key keepalive
    372                                    reuse-address
    373                                    nodelay
    374                                    broadcast
    375                                    linger
    376                                    address-family
    377                                    local-port
    378                                    local-host
    379                                    local-filename
    380                                    type
    381                                    connect
    382                                    out-of-band-inline
    383                                    &allow-other-keys)
     389(defun set-socket-options (fd-or-socket &key
     390                           keepalive
     391                           reuse-address
     392                           nodelay
     393                           broadcast
     394                           linger
     395                           address-family
     396                           local-port
     397                           local-host
     398                           local-filename
     399                           type
     400                           connect
     401                           out-of-band-inline
     402                           &allow-other-keys)
    384403  ;; see man socket(7) tcp(7) ip(7)
    385   (if (null address-family)
    386     (setq address-family :internet))
    387   (when keepalive
    388     (int-setsockopt fd #$SOL_SOCKET #$SO_KEEPALIVE 1))
    389   (when reuse-address
    390     (int-setsockopt fd #$SOL_SOCKET #$SO_REUSEADDR 1))
    391   (when broadcast
    392     (int-setsockopt fd #$SOL_SOCKET #$SO_BROADCAST 1))
    393   (when out-of-band-inline
    394     (int-setsockopt fd #$SOL_SOCKET #$SO_OOBINLINE 1))
    395   (rlet ((plinger :linger))
    396     (setf (pref plinger :linger.l_onoff) (if linger 1 0)
    397           (pref plinger :linger.l_linger) (or linger 0))
    398     (socket-call nil "setsockopt"
    399                  (c_setsockopt fd #$SOL_SOCKET #$SO_LINGER plinger 8)))
    400   (when (eq address-family :internet)
    401     (when nodelay
    402       (int-setsockopt fd
    403                       #+linuxppc-target #$SOL_TCP
    404                       #+darwinppc-target #$IPPROTO_TCP
    405                       #$TCP_NODELAY 1))
    406     (when (or local-port local-host)
    407       (let* ((proto (if (eq type :stream) "tcp" "udp"))
    408              (port-n (if local-port (port-as-inet-port local-port proto) 0))
    409              (host-n (if local-host (host-as-inet-host local-host) #$INADDR_ANY)))
    410         ;; Darwin includes the SIN_ZERO field of the sockaddr_in when
    411         ;; comparing the requested address to the addresses of configured
    412         ;; interfaces (as if the zeros were somehow part of either address.)
    413         ;; "rletz" zeros out the stack-allocated structure, so those zeros
    414         ;; will be 0.
    415         (rletz ((sockaddr :sockaddr_in))
    416                (setf (pref sockaddr :sockaddr_in.sin_family) #$AF_INET
    417                      (pref sockaddr :sockaddr_in.sin_port) port-n
    418                      (pref sockaddr :sockaddr_in.sin_addr.s_addr) host-n)
    419                (socket-call nil "bind" (c_bind fd sockaddr (record-length :sockaddr_in)))))))
    420   (when (and (eq address-family :file)
    421              (eq connect :passive)
    422              local-filename)
    423     (bind-unix-socket fd local-filename))   
    424   (when *multiprocessing-socket-io*
    425     (socket-call nil "fcntl" (fd-set-flag fd #$O_NONBLOCK))))
     404  (multiple-value-bind (socket fd) (etypecase fd-or-socket
     405                                     (socket (values fd-or-socket (socket-device fd-or-socket)))
     406                                     (integer (values nil fd-or-socket)))
     407   
     408    (if (null address-family)
     409        (setq address-family :internet))
     410    (when keepalive
     411      (int-setsockopt fd #$SOL_SOCKET #$SO_KEEPALIVE 1))
     412    (when reuse-address
     413      (int-setsockopt fd #$SOL_SOCKET #$SO_REUSEADDR 1))
     414    (when broadcast
     415      (int-setsockopt fd #$SOL_SOCKET #$SO_BROADCAST 1))
     416    (when out-of-band-inline
     417      (int-setsockopt fd #$SOL_SOCKET #$SO_OOBINLINE 1))
     418    (rlet ((plinger :linger))
     419          (setf (pref plinger :linger.l_onoff) (if linger 1 0)
     420                (pref plinger :linger.l_linger) (or linger 0))
     421          (socket-call socket "setsockopt"
     422                       (c_setsockopt fd #$SOL_SOCKET #$SO_LINGER plinger 8)))
     423    (when (eq address-family :internet)
     424      (when nodelay
     425        (int-setsockopt fd
     426                        #+linuxppc-target #$SOL_TCP
     427                        #+darwinppc-target #$IPPROTO_TCP
     428                        #$TCP_NODELAY 1))
     429      (when (or local-port local-host)
     430        (let* ((proto (if (eq type :stream) "tcp" "udp"))
     431               (port-n (if local-port (port-as-inet-port local-port proto) 0))
     432               (host-n (if local-host (host-as-inet-host local-host) #$INADDR_ANY)))
     433          ;; Darwin includes the SIN_ZERO field of the sockaddr_in when
     434          ;; comparing the requested address to the addresses of configured
     435          ;; interfaces (as if the zeros were somehow part of either address.)
     436          ;; "rletz" zeros out the stack-allocated structure, so those zeros
     437          ;; will be 0.
     438          (rletz ((sockaddr :sockaddr_in))
     439                 (setf (pref sockaddr :sockaddr_in.sin_family) #$AF_INET
     440                       (pref sockaddr :sockaddr_in.sin_port) port-n
     441                       (pref sockaddr :sockaddr_in.sin_addr.s_addr) host-n)
     442                 (socket-call socket "bind" (c_bind fd sockaddr (record-length :sockaddr_in)))))))
     443    (when (and (eq address-family :file)
     444               (eq connect :passive)
     445               local-filename)
     446      (bind-unix-socket fd local-filename))   
     447    (when *multiprocessing-socket-io*
     448      (socket-call socket "fcntl" (fd-set-flag fd #$O_NONBLOCK)))))
    426449
    427450;; I hope the inline declaration makes the &rest/apply's go away...
     
    508531      (process-output-wait fd)
    509532      (setq err (- (int-getsockopt fd #$SOL_SOCKET #$SO_ERROR))))
    510     (unless (eql err 0) (socket-error "connect" err))))
     533    (unless (eql err 0) (socket-error nil "connect" err))))
    511534   
    512535(defun inet-connect (fd host-n port-n)
     
    621644                 (setq fd -1)))
    622645              ((eql fd (- #$EAGAIN)) nil)
    623               (t (socket-error "accept" fd))))
     646              (t (socket-error socket "accept" fd))))
    624647      (when (>= fd 0)
    625648        (fd-close fd)))))
     
    652675    (unless remote-host
    653676      (setq remote-host (or (getf (socket-keys socket) :remote-host)
    654                             (remote-socket-info fd :host))))
     677                            (remote-socket-info socket :host))))
    655678    (unless remote-port
    656679      (setq remote-port (or (getf (socket-keys socket) :remote-port)
    657                             (remote-socket-info fd :port))))
     680                            (remote-socket-info socket :port))))
    658681    (rlet ((sockaddr :sockaddr_in))
    659682      (setf (pref sockaddr :sockaddr_in.sin_family) #$AF_INET)
     
    722745        (string (_getservbyname port proto))
    723746        (symbol (_getservbyname (string-downcase (symbol-name port)) proto)))
    724       (socket-error "getservbyname" (- #$ENOENT))))
     747      (socket-error nil "getservbyname" (- #$ENOENT))))
    725748
    726749(defun LOOKUP-PORT (port proto)
     
    738761                (multiple-value-bind (addr err) (c_gethostbyname host)
    739762                  (or addr
    740                       (socket-error "gethostbyname" err t)))))))
     763                      (socket-error nil "gethostbyname" err t)))))))
    741764
    742765
     
    762785  (declare (ignore ignore-cache))
    763786  (multiple-value-bind (name err) (c_gethostbyaddr (#_htonl ipaddr))
    764     (or name (socket-error "gethostbyaddr" err t))))
     787    (or name (socket-error nil "gethostbyaddr" err t))))
    765788 
    766789
     
    774797               (eql 4 (pref vallen :signed)))
    775798        (pref valptr :signed)
    776         (socket-error "getsockopt" err)))))
     799        (socket-error socket "getsockopt" err)))))
    777800
    778801(defun int-setsockopt (socket level optname optval)
Note: See TracChangeset for help on using the changeset viewer.