3rdparties/software/usocket-0.8.3/backend/allegro.lisp (8591 bytes)
1 ;;;; See LICENSE for licensing information. 2 3 (in-package :usocket) 4 5 #+cormanlisp 6 (eval-when (:compile-toplevel :load-toplevel :execute) 7 (require :acl-socket)) 8 9 #+allegro 10 (eval-when (:compile-toplevel :load-toplevel :execute) 11 (require :sock) 12 ;; for wait-for-input: 13 (require :process) 14 ;; note: the line below requires ACL 6.2+ 15 (require :osi)) 16 17 (defun get-host-name () 18 ;; note: the line below requires ACL 7.0+ to actually *work* on windows 19 #+allegro (excl.osi:gethostname) 20 #+cormanlisp "") 21 22 (defparameter +allegro-identifier-error-map+ 23 '((:address-in-use . address-in-use-error) 24 (:address-not-available . address-not-available-error) 25 (:network-down . network-down-error) 26 (:network-reset . network-reset-error) 27 (:network-unreachable . network-unreachable-error) 28 (:connection-aborted . connection-aborted-error) 29 (:connection-reset . connection-reset-error) 30 (:no-buffer-space . no-buffers-error) 31 (:shutdown . shutdown-error) 32 (:connection-timed-out . timeout-error) 33 (:connection-refused . connection-refused-error) 34 (:host-down . host-down-error) 35 (:host-unreachable . host-unreachable-error))) 36 37 ;; TODO: what's the error class of Corman Lisp? 38 (defun handle-condition (condition &optional (socket nil) (host-or-ip nil)) 39 "Dispatch correct usocket condition." 40 (typecase condition 41 #+allegro 42 (excl:socket-error 43 (let ((usock-error 44 (cdr (assoc (excl:stream-error-identifier condition) 45 +allegro-identifier-error-map+)))) 46 (declare (type symbol usock-error)) 47 (if usock-error 48 (cond ((subtypep usock-error 'ns-error) 49 (error usock-error :socket socket :host-or-ip host-or-ip)) 50 (t 51 (error usock-error :socket socket))) 52 (error 'unknown-error 53 :real-error condition 54 :socket socket)))))) 55 56 (defun to-format (element-type) 57 (if (subtypep element-type 'character) 58 :text 59 :binary)) 60 61 (defun socket-connect (host port &key (protocol :stream) (element-type 'character) 62 timeout deadline 63 (nodelay t) ;; nodelay == t is the ACL default 64 local-host local-port) 65 (when timeout (unsupported 'timeout 'socket-connect)) 66 (when deadline (unsupported 'deadline 'socket-connect)) 67 (when (eq nodelay :if-supported) 68 (setf nodelay t)) 69 70 (let ((socket)) 71 (setf socket 72 (with-mapped-conditions (socket (or host local-host)) 73 (ecase protocol 74 (:stream 75 (labels ((make-socket () 76 (socket:make-socket :remote-host (host-to-hostname host) 77 :remote-port port 78 :local-host (when local-host 79 (host-to-hostname local-host)) 80 :local-port local-port 81 :format (to-format element-type) 82 :nodelay nodelay))) 83 #+allegro 84 (if timeout 85 (mp:with-timeout (timeout nil) 86 (make-socket)) 87 (make-socket)) 88 #+cormanlisp (make-socket))) 89 (:datagram 90 (apply #'socket:make-socket 91 (nconc (list :type protocol 92 :address-family :internet 93 :local-host (when local-host 94 (host-to-hostname local-host)) 95 :local-port local-port 96 :format (to-format element-type)) 97 (if (and host port) 98 (list :connect :active 99 :remote-host (host-to-hostname host) 100 :remote-port port) 101 (list :connect :passive)))))))) 102 (ecase protocol 103 (:stream 104 (make-stream-socket :socket socket :stream socket)) 105 (:datagram 106 (make-datagram-socket socket :connected-p (and host port t)))))) 107 108 ;; One socket close method is sufficient, 109 ;; because socket-streams are also sockets. 110 (defmethod socket-close ((usocket usocket)) 111 "Close socket." 112 (with-mapped-conditions (usocket) 113 (close (socket usocket)))) 114 115 (defmethod socket-shutdown ((usocket stream-usocket) direction) 116 (with-mapped-conditions (usocket) 117 (socket:shutdown (socket usocket) :direction direction))) 118 119 (defun socket-listen (host port 120 &key reuseaddress 121 (reuse-address nil reuse-address-supplied-p) 122 (backlog 5) 123 (element-type 'character)) 124 ;; Allegro and OpenMCL socket interfaces bear very strong resemblence 125 ;; whatever you change here, change it also for OpenMCL 126 (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress)) 127 (sock (with-mapped-conditions (nil host) 128 (apply #'socket:make-socket 129 (append (list :connect :passive 130 :reuse-address reuseaddress 131 :local-port port 132 :backlog backlog 133 :format (to-format element-type) 134 ;; allegro now ignores :format 135 ) 136 (when (ip/= host *wildcard-host*) 137 (list :local-host host))))))) 138 (make-stream-server-socket sock :element-type element-type))) 139 140 (defmethod socket-accept ((socket stream-server-usocket) &key element-type) 141 (declare (ignore element-type)) ;; allegro streams are multivalent 142 (let ((stream-sock 143 (with-mapped-conditions (socket) 144 (socket:accept-connection (socket socket))))) 145 (make-stream-socket :socket stream-sock :stream stream-sock))) 146 147 (defmethod get-local-address ((usocket usocket)) 148 (hbo-to-vector-quad (socket:local-host (socket usocket)))) 149 150 (defmethod get-peer-address ((usocket stream-usocket)) 151 (hbo-to-vector-quad (socket:remote-host (socket usocket)))) 152 153 (defmethod get-local-port ((usocket usocket)) 154 (socket:local-port (socket usocket))) 155 156 (defmethod get-peer-port ((usocket stream-usocket)) 157 #+allegro 158 (socket:remote-port (socket usocket))) 159 160 (defmethod get-local-name ((usocket usocket)) 161 (values (get-local-address usocket) 162 (get-local-port usocket))) 163 164 (defmethod get-peer-name ((usocket stream-usocket)) 165 (values (get-peer-address usocket) 166 (get-peer-port usocket))) 167 168 #+allegro 169 (defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0)) 170 (with-mapped-conditions (usocket host) 171 (let ((s (socket usocket))) 172 (socket:send-to s 173 (if (zerop offset) 174 buffer 175 (subseq buffer offset (+ offset size))) 176 size 177 :remote-host host 178 :remote-port port)))) 179 180 #+allegro 181 (defmethod socket-receive ((usocket datagram-usocket) buffer length &key) 182 (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer 183 (integer 0) ; size 184 (unsigned-byte 32) ; host 185 (unsigned-byte 16))) ; port 186 (with-mapped-conditions (usocket) 187 (let ((s (socket usocket))) 188 (socket:receive-from s length :buffer buffer :extract t)))) 189 190 (defun get-host-by-address (address) 191 (with-mapped-conditions (nil address) 192 (socket:ipaddr-to-hostname (host-to-hbo address)))) 193 194 (defun get-hosts-by-name (name) 195 ;;###FIXME: ACL has the acldns module which returns all A records 196 ;; only problem: it doesn't fall back to tcp (from udp) if the returned 197 ;; structure is too long. 198 (with-mapped-conditions (nil name) 199 (list (hbo-to-vector-quad (socket:lookup-hostname 200 (host-to-hostname name)))))) 201 202 (defun %setup-wait-list (wait-list) 203 (declare (ignore wait-list))) 204 205 (defun %add-waiter (wait-list waiter) 206 (push (socket waiter) (wait-list-%wait wait-list))) 207 208 (defun %remove-waiter (wait-list waiter) 209 (setf (wait-list-%wait wait-list) 210 (remove (socket waiter) (wait-list-%wait wait-list)))) 211 212 #+allegro 213 (defun wait-for-input-internal (wait-list &key timeout) 214 (with-mapped-conditions () 215 (let ((active-internal-sockets 216 (if timeout 217 (mp:wait-for-input-available (wait-list-%wait wait-list) 218 :timeout timeout) 219 (mp:wait-for-input-available (wait-list-%wait wait-list))))) 220 ;; this is quadratic, but hey, the active-internal-sockets 221 ;; list is very short and it's only quadratic in the length of that one. 222 ;; When I have more time I could recode it to something of linear 223 ;; complexity. 224 ;; [Same code is also used in openmcl.lisp] 225 (dolist (x active-internal-sockets) 226 (setf (state (gethash x (wait-list-map wait-list))) 227 :read)) 228 wait-list)))