Changeset 768
- Timestamp:
- Apr 12, 2004, 12:29:13 PM (21 years ago)
- File:
-
- 1 edited
-
trunk/ccl/level-1/l1-sockets.lisp (modified) (11 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/ccl/level-1/l1-sockets.lisp
r440 r768 117 117 ((code :initarg :code :reader socket-error-code) 118 118 (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))) 120 125 121 126 (defvar *socket-error-identifiers* … … 155 160 156 161 (defun socket-error (stream where errno &optional nameserver-p) 162 "Creates and signals (via error) one of two socket error 163 conditions, based on the state of the arguments." 157 164 (when (< errno 0) 158 165 (setq errno (- errno))) … … 171 178 (%strerror errno)) 172 179 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))))) 178 192 179 193 … … 324 338 (path-from-unix-address addr)))) 325 339 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))))))) 351 369 352 370 (defmethod LOCAL-PORT ((socket socket)) 353 (local-socket-info (socket-device socket):port socket))371 (local-socket-info socket :port socket)) 354 372 355 373 (defmethod LOCAL-HOST ((socket socket)) 356 (local-socket-info (socket-device socket):host socket))374 (local-socket-info socket :host socket)) 357 375 358 376 (defmethod LOCAL-FILENAME ((socket socket)) 359 (local-socket-filename (socket-device socket)socket))377 (local-socket-filename socket)) 360 378 361 379 ;; Returns NIL if socket is not connected 362 380 (defmethod REMOTE-HOST ((socket socket)) 363 (remote-socket-info (socket-device socket):host))381 (remote-socket-info socket :host)) 364 382 365 383 (defmethod REMOTE-PORT ((socket socket)) 366 (remote-socket-info (socket-device socket):port))384 (remote-socket-info socket :port)) 367 385 368 386 (defmethod REMOTE-FILENAME ((socket socket)) 369 (remote-socket-filename (socket-device socket)))387 (remote-socket-filename socket)) 370 388 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) 384 403 ;; 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))))) 426 449 427 450 ;; I hope the inline declaration makes the &rest/apply's go away... … … 508 531 (process-output-wait fd) 509 532 (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)))) 511 534 512 535 (defun inet-connect (fd host-n port-n) … … 621 644 (setq fd -1))) 622 645 ((eql fd (- #$EAGAIN)) nil) 623 (t (socket-error "accept" fd))))646 (t (socket-error socket "accept" fd)))) 624 647 (when (>= fd 0) 625 648 (fd-close fd))))) … … 652 675 (unless remote-host 653 676 (setq remote-host (or (getf (socket-keys socket) :remote-host) 654 (remote-socket-info fd:host))))677 (remote-socket-info socket :host)))) 655 678 (unless remote-port 656 679 (setq remote-port (or (getf (socket-keys socket) :remote-port) 657 (remote-socket-info fd:port))))680 (remote-socket-info socket :port)))) 658 681 (rlet ((sockaddr :sockaddr_in)) 659 682 (setf (pref sockaddr :sockaddr_in.sin_family) #$AF_INET) … … 722 745 (string (_getservbyname port proto)) 723 746 (symbol (_getservbyname (string-downcase (symbol-name port)) proto))) 724 (socket-error "getservbyname" (- #$ENOENT))))747 (socket-error nil "getservbyname" (- #$ENOENT)))) 725 748 726 749 (defun LOOKUP-PORT (port proto) … … 738 761 (multiple-value-bind (addr err) (c_gethostbyname host) 739 762 (or addr 740 (socket-error "gethostbyname" err t)))))))763 (socket-error nil "gethostbyname" err t))))))) 741 764 742 765 … … 762 785 (declare (ignore ignore-cache)) 763 786 (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)))) 765 788 766 789 … … 774 797 (eql 4 (pref vallen :signed))) 775 798 (pref valptr :signed) 776 (socket-error "getsockopt" err)))))799 (socket-error socket "getsockopt" err))))) 777 800 778 801 (defun int-setsockopt (socket level optname optval)
Note:
See TracChangeset
for help on using the changeset viewer.
