openmcl.lisp - clic - Clic is an command line interactive client for gopher wri… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
openmcl.lisp (10491B) | |
--- | |
1 ;;;; See LICENSE for licensing information. | |
2 | |
3 (in-package :usocket) | |
4 | |
5 (defun get-host-name () | |
6 (ccl::%stack-block ((resultbuf 256)) | |
7 (when (zerop (#_gethostname resultbuf 256)) | |
8 (ccl::%get-cstring resultbuf)))) | |
9 | |
10 (defparameter +openmcl-error-map+ | |
11 '((:address-in-use . address-in-use-error) | |
12 (:connection-aborted . connection-aborted-error) | |
13 (:no-buffer-space . no-buffers-error) | |
14 (:connection-timed-out . timeout-error) | |
15 (:connection-refused . connection-refused-error) | |
16 (:host-unreachable . host-unreachable-error) | |
17 (:host-down . host-down-error) | |
18 (:network-down . network-down-error) | |
19 (:address-not-available . address-not-available-error) | |
20 (:network-reset . network-reset-error) | |
21 (:connection-reset . connection-reset-error) | |
22 (:shutdown . shutdown-error) | |
23 (:access-denied . operation-not-permitted-error))) | |
24 | |
25 (defparameter +openmcl-nameserver-error-map+ | |
26 '((:no-recovery . ns-no-recovery-error) | |
27 (:try-again . ns-try-again-condition) | |
28 (:host-not-found . ns-host-not-found-error))) | |
29 | |
30 ;; we need something which the openmcl implementors 'forgot' to do: | |
31 ;; wait for more than one socket-or-fd | |
32 | |
33 (defun input-available-p (sockets &optional ticks-to-wait) | |
34 (ccl::rletz ((tv :timeval)) | |
35 (ccl::ticks-to-timeval ticks-to-wait tv) | |
36 ;;### The trickery below can be moved to the wait-list now... | |
37 (ccl::%stack-block ((infds ccl::*fd-set-size*)) | |
38 (ccl::fd-zero infds) | |
39 (let ((max-fd -1)) | |
40 (dolist (sock sockets) | |
41 (let ((fd (openmcl-socket:socket-os-fd (socket sock)))) | |
42 (when fd ;; may be NIL if closed | |
43 (setf max-fd (max max-fd fd)) | |
44 (ccl::fd-set fd infds)))) | |
45 (let ((res (#_select (1+ max-fd) | |
46 infds (ccl::%null-ptr) (ccl::%null-ptr) | |
47 (if ticks-to-wait tv (ccl::%null-ptr))))) | |
48 (when (> res 0) | |
49 (dolist (sock sockets) | |
50 (let ((fd (openmcl-socket:socket-os-fd (socket sock)))) | |
51 (when (and fd (ccl::fd-is-set fd infds)) | |
52 (setf (state sock) :READ))))) | |
53 sockets))))) | |
54 | |
55 (defun raise-error-from-id (condition-id socket real-condition) | |
56 (let ((usock-err (cdr (assoc condition-id +openmcl-error-map+)))) | |
57 (if usock-err | |
58 (error usock-err :socket socket) | |
59 (error 'unknown-error :socket socket :real-error real-condition)))) | |
60 | |
61 (defun handle-condition (condition &optional socket (host-or-ip nil)) | |
62 (typecase condition | |
63 (openmcl-socket:socket-error | |
64 (raise-error-from-id (openmcl-socket:socket-error-identifier cond… | |
65 socket condition)) | |
66 (ccl:input-timeout | |
67 (error 'timeout-error :socket socket)) | |
68 (ccl:communication-deadline-expired | |
69 (error 'deadline-timeout-error :socket socket)) | |
70 (ccl::socket-creation-error #| ugh! |# | |
71 (let* ((condition-id (ccl::socket-creation-error-identifier condi… | |
72 (nameserver-error (cdr (assoc condition-id | |
73 +openmcl-nameserver-error-ma… | |
74 (if nameserver-error | |
75 (if (typep nameserver-error 'serious-condition) | |
76 (error nameserver-error :host-or-ip host-or-ip) | |
77 (signal nameserver-error :host-or-ip host-or-ip)) | |
78 (raise-error-from-id condition-id socket condition)))))) | |
79 | |
80 (defun to-format (element-type protocol) | |
81 (cond ((null element-type) | |
82 (ecase protocol ; default value of different protocol | |
83 (:stream :text) | |
84 (:datagram :binary))) | |
85 ((subtypep element-type 'character) | |
86 :text) | |
87 (t :binary))) | |
88 | |
89 #-ipv6 | |
90 (defun socket-connect (host port &key (protocol :stream) element-type | |
91 timeout deadline nodelay | |
92 local-host local-port) | |
93 (when (eq nodelay :if-supported) | |
94 (setf nodelay t)) | |
95 (with-mapped-conditions (nil host) | |
96 (ecase protocol | |
97 (:stream | |
98 (let ((mcl-sock | |
99 (openmcl-socket:make-socket :remote-host (host-to-hostname… | |
100 :remote-port port | |
101 :local-host local-host | |
102 :local-port local-port | |
103 :format (to-format element-typ… | |
104 :external-format ccl:*default-… | |
105 :deadline deadline | |
106 :nodelay nodelay | |
107 :connect-timeout timeout))) | |
108 (make-stream-socket :stream mcl-sock :socket mcl-sock))) | |
109 (:datagram | |
110 (let* ((mcl-sock | |
111 (openmcl-socket:make-socket :address-family :internet | |
112 :type :datagram | |
113 :local-host local-host | |
114 :local-port local-port | |
115 :input-timeout timeout | |
116 :format (to-format element-ty… | |
117 :external-format ccl:*default… | |
118 (usocket (make-datagram-socket mcl-sock))) | |
119 (when (and host port) | |
120 (ccl::inet-connect (ccl::socket-device mcl-sock) | |
121 (ccl::host-as-inet-host host) | |
122 (ccl::port-as-inet-port port "udp"))) | |
123 (setf (connected-p usocket) t) | |
124 usocket))))) | |
125 | |
126 #-ipv6 | |
127 (defun socket-listen (host port | |
128 &key reuseaddress | |
129 (reuse-address nil reuse-address-supplied-p) | |
130 (backlog 5) | |
131 (element-type 'character)) | |
132 (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reusea… | |
133 (real-host (host-to-hostname host)) | |
134 (sock (with-mapped-conditions (nil host) | |
135 (apply #'openmcl-socket:make-socket | |
136 (append (list :connect :passive | |
137 :reuse-address reuseaddress | |
138 :local-port port | |
139 :backlog backlog | |
140 :format (to-format element-type :… | |
141 (unless (eq host *wildcard-host*) | |
142 (list :local-host real-host))))))) | |
143 (make-stream-server-socket sock :element-type element-type))) | |
144 | |
145 (defmethod socket-accept ((usocket stream-server-usocket) &key element-t… | |
146 (declare (ignore element-type)) ;; openmcl streams are bi/multivalent | |
147 (let ((sock (with-mapped-conditions (usocket) | |
148 (openmcl-socket:accept-connection (socket usocket))))) | |
149 (make-stream-socket :socket sock :stream sock))) | |
150 | |
151 ;; One close method is sufficient because sockets | |
152 ;; and their associated objects are represented | |
153 ;; by the same object. | |
154 (defmethod socket-close ((usocket usocket)) | |
155 (with-mapped-conditions (usocket) | |
156 (close (socket usocket)))) | |
157 | |
158 (defmethod socket-shutdown ((usocket usocket) direction) | |
159 (with-mapped-conditions (usocket) | |
160 (openmcl-socket:shutdown (socket usocket) :direction direction))) | |
161 | |
162 #-ipv6 | |
163 (defmethod socket-send ((usocket datagram-usocket) buffer size &key host… | |
164 (with-mapped-conditions (usocket host) | |
165 (if (and host port) | |
166 (openmcl-socket:send-to (socket usocket) buffer size | |
167 :remote-host (host-to-hbo host) | |
168 :remote-port port | |
169 :offset offset) | |
170 ;; Clozure CL's socket function SEND-TO doesn't support operatio… | |
171 ;; so we have to define our own. | |
172 (let* ((socket (socket usocket)) | |
173 (fd (ccl::socket-device socket))) | |
174 (multiple-value-setq (buffer offset) | |
175 (ccl::verify-socket-buffer buffer offset size)) | |
176 (ccl::%stack-block ((bufptr size)) | |
177 (ccl::%copy-ivector-to-ptr buffer offset bufptr 0 size) | |
178 (ccl::socket-call socket "send" | |
179 (ccl::with-eagain fd :output | |
180 (ccl::ignoring-eintr | |
181 (ccl::check-socket-error (#_send fd bufptr size 0)))))… | |
182 | |
183 (defmethod socket-receive ((usocket datagram-usocket) buffer length &key) | |
184 (with-mapped-conditions (usocket) | |
185 (openmcl-socket:receive-from (socket usocket) length :buffer buffer)… | |
186 | |
187 (defun usocket-host-address (address) | |
188 (cond | |
189 ((integerp address) | |
190 (hbo-to-vector-quad address)) | |
191 ((and (arrayp address) | |
192 (= (length address) 16) | |
193 (every #'= address #(0 0 0 0 0 0 0 0 0 0 #xff #xff))) | |
194 (make-array 4 :displaced-to address :displaced-index-offset 12)) | |
195 (t | |
196 address))) | |
197 | |
198 (defmethod get-local-address ((usocket usocket)) | |
199 (usocket-host-address (openmcl-socket:local-host (socket usocket)))) | |
200 | |
201 (defmethod get-peer-address ((usocket stream-usocket)) | |
202 (usocket-host-address (openmcl-socket:remote-host (socket usocket)))) | |
203 | |
204 (defmethod get-local-port ((usocket usocket)) | |
205 (openmcl-socket:local-port (socket usocket))) | |
206 | |
207 (defmethod get-peer-port ((usocket stream-usocket)) | |
208 (openmcl-socket:remote-port (socket usocket))) | |
209 | |
210 (defmethod get-local-name ((usocket usocket)) | |
211 (values (get-local-address usocket) | |
212 (get-local-port usocket))) | |
213 | |
214 (defmethod get-peer-name ((usocket stream-usocket)) | |
215 (values (get-peer-address usocket) | |
216 (get-peer-port usocket))) | |
217 | |
218 (defun get-host-by-address (address) | |
219 (with-mapped-conditions (nil address) | |
220 (openmcl-socket:ipaddr-to-hostname (host-to-hbo address)))) | |
221 | |
222 (defun get-hosts-by-name (name) | |
223 (with-mapped-conditions (nil name) | |
224 (list (hbo-to-vector-quad (openmcl-socket:lookup-hostname | |
225 (host-to-hostname name)))))) | |
226 | |
227 (defun %setup-wait-list (wait-list) | |
228 (declare (ignore wait-list))) | |
229 | |
230 (defun %add-waiter (wait-list waiter) | |
231 (declare (ignore wait-list waiter))) | |
232 | |
233 (defun %remove-waiter (wait-list waiter) | |
234 (declare (ignore wait-list waiter))) | |
235 | |
236 (defun wait-for-input-internal (wait-list &key timeout) | |
237 (with-mapped-conditions () | |
238 (let* ((ticks-timeout (truncate (* (or timeout 1) | |
239 ccl::*ticks-per-second*)))) | |
240 (input-available-p (wait-list-waiters wait-list) | |
241 (when timeout ticks-timeout)) | |
242 wait-list))) | |
243 | |
244 ;;; Helper functions for option.lisp | |
245 | |
246 (defun get-socket-option-reuseaddr (socket) | |
247 (ccl::int-getsockopt (ccl::socket-device socket) | |
248 #$SOL_SOCKET #$SO_REUSEADDR)) | |
249 | |
250 (defun set-socket-option-reuseaddr (socket value) | |
251 (ccl::int-setsockopt (ccl::socket-device socket) | |
252 #$SOL_SOCKET #$SO_REUSEADDR value)) | |
253 | |
254 (defun get-socket-option-broadcast (socket) | |
255 (ccl::int-getsockopt (ccl::socket-device socket) | |
256 #$SOL_SOCKET #$SO_BROADCAST)) | |
257 | |
258 (defun set-socket-option-broadcast (socket value) | |
259 (ccl::int-setsockopt (ccl::socket-device socket) | |
260 #$SOL_SOCKET #$SO_BROADCAST value)) | |
261 | |
262 (defun get-socket-option-tcp-nodelay (socket) | |
263 (ccl::int-getsockopt (ccl::socket-device socket) | |
264 #$IPPROTO_TCP #$TCP_NODELAY)) | |
265 | |
266 (defun set-socket-option-tcp-nodelay (socket value) | |
267 (ccl::int-setsockopt (ccl::socket-device socket) | |
268 #$IPPROTO_TCP #$TCP_NODELAY value)) |