Changeset 423
- Timestamp:
- Jan 30, 2004, 11:36:15 AM (21 years ago)
- File:
-
- 1 edited
-
trunk/ccl/level-1/l1-sockets.lisp (modified) (23 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/ccl/level-1/l1-sockets.lisp
r384 r423 114 114 (require "DARWIN-SYSCALLS")) 115 115 116 (define-condition socket-error (simple- error)116 (define-condition socket-error (simple-stream-error) 117 117 ((code :initarg :code :reader socket-error-code) 118 118 (identifier :initform :unknown :initarg :identifier :reader socket-error-identifier) … … 131 131 #$EHOSTDOWN :host-down 132 132 #$ENETDOWN :network-down 133 ;; ??:address-not-available134 ;; ??:network-reset135 ;; ??:connection-reset136 ;; ??:shutdown133 #$EADDRNOTAVAIL :address-not-available 134 #$ENETRESET :network-reset 135 #$ECONNRESET :connection-reset 136 #$ESHUTDOWN :shutdown 137 137 #$EACCES :access-denied 138 138 #$EPERM :access-denied)) … … 140 140 141 141 (declaim (inline socket-call)) 142 (defun socket-call ( where res)142 (defun socket-call (stream where res) 143 143 (if (< res 0) 144 (socket-error where res)144 (socket-error stream where res) 145 145 res)) 146 146 … … 151 151 (format nil "Nameserver error ~d" (abs h_errno))))) 152 152 153 154 (defun socket-error (where errno &optional nameserver-p) 153 154 155 156 (defun socket-error (stream where errno &optional nameserver-p) 155 157 (when (< errno 0) 156 158 (setq errno (- errno))) 157 (error (make-condition 'socket-error 158 :code errno 159 :identifier (getf *socket-error-identifiers* errno :unknown) 160 :situation where 161 ;; TODO: this is a constant arg, there is a way to put this 162 ;; in the class definition, just need to remember how... 163 :format-control "~a (error #~d) in ~a" 164 :format-arguments (list 165 (if nameserver-p 166 (%hstrerror errno) 167 (%strerror errno)) 168 errno where)))) 159 (if stream 160 (error (make-condition 'socket-error 161 :stream stream 162 :code errno 163 :identifier (getf *socket-error-identifiers* errno :unknown) 164 :situation where 165 ;; TODO: this is a constant arg, there is a way to put this 166 ;; in the class definition, just need to remember how... 167 :format-control "~a (error #~d) on ~s in ~a" 168 :format-arguments (list 169 (if nameserver-p 170 (%hstrerror errno) 171 (%strerror errno)) 172 errno stream where))) 173 (error "~a (error #~d) in ~a" 174 (if nameserver-p 175 (%hstrerror errno) 176 (%strerror errno)) 177 errno where))) 178 179 169 180 170 181 ;; If true, this will try to allow other processes to run while … … 286 297 287 298 ;; Returns nil for closed stream 288 (defun local-socket-info (fd type )299 (defun local-socket-info (fd type socket) 289 300 (and fd 290 301 (rlet ((sockaddr :sockaddr_in) 291 302 (namelen :signed)) 292 303 (setf (pref namelen :signed) (record-length :sockaddr_in)) 293 (socket-call "getsockname" (c_getsockname fd sockaddr namelen))304 (socket-call socket "getsockname" (c_getsockname fd sockaddr namelen)) 294 305 (when (= #$AF_INET (pref sockaddr :sockaddr_in.sin_family)) 295 306 (ecase type … … 305 316 (%get-cstring (pref addr :sockaddr_un.sun_path)))) 306 317 307 (defun local-socket-filename (fd )318 (defun local-socket-filename (fd socket) 308 319 (and fd 309 320 (rlet ((addr :sockaddr_un) 310 321 (namelen :signed)) 311 322 (setf (pref namelen :signed) (record-length :sockaddr_un)) 312 (socket-call "getsockname" (c_getsockname fd addr namelen))323 (socket-call socket "getsockname" (c_getsockname fd addr namelen)) 313 324 (path-from-unix-address addr)))) 314 325 … … 340 351 341 352 (defmethod LOCAL-PORT ((socket socket)) 342 (local-socket-info (socket-device socket) :port ))353 (local-socket-info (socket-device socket) :port socket)) 343 354 344 355 (defmethod LOCAL-HOST ((socket socket)) 345 (local-socket-info (socket-device socket) :host ))356 (local-socket-info (socket-device socket) :host socket)) 346 357 347 358 (defmethod LOCAL-FILENAME ((socket socket)) 348 (local-socket-filename (socket-device socket) ))359 (local-socket-filename (socket-device socket) socket)) 349 360 350 361 ;; Returns NIL if socket is not connected … … 385 396 (setf (pref plinger :linger.l_onoff) (if linger 1 0) 386 397 (pref plinger :linger.l_linger) (or linger 0)) 387 (socket-call "setsockopt"398 (socket-call nil "setsockopt" 388 399 (c_setsockopt fd #$SOL_SOCKET #$SO_LINGER plinger 8))) 389 400 (when (eq address-family :internet) … … 406 417 (pref sockaddr :sockaddr_in.sin_port) port-n 407 418 (pref sockaddr :sockaddr_in.sin_addr.s_addr) host-n) 408 (socket-call "bind" (c_bind fd sockaddr (record-length :sockaddr_in)))))))419 (socket-call nil "bind" (c_bind fd sockaddr (record-length :sockaddr_in))))))) 409 420 (when (and (eq address-family :file) 410 421 (eq connect :passive) … … 412 423 (bind-unix-socket fd local-filename)) 413 424 (when *multiprocessing-socket-io* 414 (socket-call "fcntl" (fd-set-flag fd #$O_NONBLOCK))))425 (socket-call nil "fcntl" (fd-set-flag fd #$O_NONBLOCK)))) 415 426 416 427 ;; I hope the inline declaration makes the &rest/apply's go away... … … 451 462 (unwind-protect 452 463 (let (socket) 453 (setq fd (socket-call "socket"464 (setq fd (socket-call nil "socket" 454 465 (c_socket #$AF_INET #$SOCK_DGRAM #$IPPROTO_UDP))) 455 466 (apply #'set-socket-options fd keys) … … 465 476 (unwind-protect 466 477 (let (socket) 467 (setq fd (socket-call "socket"478 (setq fd (socket-call nil "socket" 468 479 (c_socket #$AF_INET #$SOCK_STREAM #$IPPROTO_TCP))) 469 480 (apply #'set-socket-options fd keys) … … 480 491 (unwind-protect 481 492 (let (socket) 482 (setq fd (socket-call "socket" (c_socket #$PF_LOCAL #$SOCK_STREAM 0)))493 (setq fd (socket-call nil "socket" (c_socket #$PF_LOCAL #$SOCK_STREAM 0))) 483 494 (apply #'set-socket-options fd keys) 484 495 (setq socket … … 557 568 558 569 (defun make-tcp-listener-socket (fd &rest keys &key backlog &allow-other-keys) 559 (socket-call "listen" (c_listen fd (or backlog 5)))570 (socket-call nil "listen" (c_listen fd (or backlog 5))) 560 571 (make-instance 'listener-socket 561 572 :device fd … … 563 574 564 575 (defun make-file-listener-socket (fd &rest keys &key backlog &allow-other-keys) 565 (socket-call "listen" (c_listen fd (or backlog 5)))576 (socket-call nil "listen" (c_listen fd (or backlog 5))) 566 577 (make-instance 'file-listener-socket 567 578 :device fd 568 579 :keys keys)) 569 580 570 (defun socket-accept (fd wait )581 (defun socket-accept (fd wait socket) 571 582 (flet ((_accept (fd async) 572 583 (let ((res (c_accept fd (%null-ptr) (%null-ptr)))) … … 593 604 (_accept fd t)) 594 605 (t 595 (let ((old (socket-call "fcntl" (fd-get-flags fd))))606 (let ((old (socket-call socket "fcntl" (fd-get-flags fd)))) 596 607 (unwind-protect 597 608 (progn 598 (socket-call "fcntl" (fd-set-flags fd (logior old #$O_NONBLOCK)))609 (socket-call socket "fcntl" (fd-set-flags fd (logior old #$O_NONBLOCK))) 599 610 (_accept fd t)) 600 (socket-call "fcntl" (fd-set-flags fd old))))))))611 (socket-call socket "fcntl" (fd-set-flags fd old)))))))) 601 612 602 613 (defun accept-socket-connection (socket wait stream-create-function) … … 605 616 (unwind-protect 606 617 (progn 607 (setq fd (socket-accept listen-fd wait ))618 (setq fd (socket-accept listen-fd wait socket)) 608 619 (cond ((>= fd 0) 609 620 (prog1 (apply stream-create-function fd (socket-keys socket)) … … 653 664 (%stack-block ((bufptr size)) 654 665 (%copy-ivector-to-ptr msg offset bufptr 0 size) 655 (socket-call "sendto"666 (socket-call socket "sendto" 656 667 (with-eagain fd :output 657 668 (c_sendto fd bufptr size 0 sockaddr (record-length :sockaddr_in)))))))) … … 672 683 (setf (pref namelen :signed) (record-length :sockaddr_in)) 673 684 (%stack-block ((bufptr size)) 674 (setq ret-size (socket-call "recvfrom"685 (setq ret-size (socket-call socket "recvfrom" 675 686 (with-eagain fd :input 676 687 (c_recvfrom fd bufptr size 0 sockaddr namelen)))) … … 699 710 ;; is a distinct, catchable error type). 700 711 (let ((fd (socket-device socket))) 701 (socket-call "shutdown"712 (socket-call socket "shutdown" 702 713 (c_shutdown fd (ecase direction 703 714 (:input 0) … … 768 779 (rlet ((valptr :signed)) 769 780 (setf (pref valptr :signed) optval) 770 (socket-call "setsockopt"781 (socket-call socket "setsockopt" 771 782 (c_setsockopt socket level optname valptr (record-length :signed))))) 772 783 … … 895 906 (init-unix-sockaddr addr path) 896 907 (socket-call 908 nil 897 909 "bind" 898 910 (c_bind socketfd … … 1176 1188 1177 1189 1190 (defmethod stream-io-error ((stream socket) errno where) 1191 (socket-error stream where errno))
Note:
See TracChangeset
for help on using the changeset viewer.
