tcmucl.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) LICENSE
---
tcmucl.lisp (11174B)
---
1 ;;;; See LICENSE for licensing information.
2
3 (in-package :usocket)
4
5 #+win32
6 (defun remap-for-win32 (z)
7 (mapcar #'(lambda (x)
8 (cons (mapcar #'(lambda (y)
9 (+ 10000 y))
10 (car x))
11 (cdr x)))
12 z))
13
14 (defparameter +cmucl-error-map+
15 #+win32
16 (append (remap-for-win32 +unix-errno-condition-map+)
17 (remap-for-win32 +unix-errno-error-map+))
18 #-win32
19 (append +unix-errno-condition-map+
20 +unix-errno-error-map+))
21
22 (defun cmucl-map-socket-error (err &key condition socket)
23 (let ((usock-err
24 (cdr (assoc err +cmucl-error-map+ :test #'member))))
25 (if usock-err
26 (if (subtypep usock-err 'error)
27 (error usock-err :socket socket)
28 (signal usock-err :socket socket))
29 (error 'unknown-error
30 :socket socket
31 :real-error condition))))
32
33 ;; CMUCL error handling is brain-dead: it doesn't preserve any
34 ;; information other than the OS error string from which the
35 ;; error can be determined. The OS error string isn't good enough
36 ;; given that it may have been localized (l10n).
37 ;;
38 ;; The above applies to versions pre 19b; 19d and newer are expected to
39 ;; contain even better error reporting.
40 ;;
41 ;;
42 ;; Just catch the errors and encapsulate them in an unknown-error
43 (defun handle-condition (condition &optional (socket nil))
44 "Dispatch correct usocket condition."
45 (typecase condition
46 (ext::socket-error (cmucl-map-socket-error (ext::socket-errno condition)
47 :socket socket
48 :condition condition))))
49
50 (defun socket-connect (host port &key (protocol :stream) (element-type 'character)
51 timeout deadline (nodelay t nodelay-specified)
52 (local-host nil local-host-p)
53 (local-port nil local-port-p)
54 &aux
55 (local-bind-p (fboundp 'ext::bind-inet-socket)))
56 (when timeout (unsupported 'timeout 'socket-connect))
57 (when deadline (unsupported 'deadline 'socket-connect))
58 (when (and nodelay-specified
59 (not (eq nodelay :if-supported)))
60 (unsupported 'nodelay 'socket-connect))
61 (when (and local-host-p (not local-bind-p))
62 (unsupported 'local-host 'socket-connect :minimum "Snapshot 2008-08 (19E)"))
63 (when (and local-port-p (not local-bind-p))
64 (unsupported 'local-port 'socket-connect :minimum "Snapshot 2008-08 (19E)"))
65
66 (let ((socket))
67 (ecase protocol
68 (:stream
69 (setf socket
70 (let ((args (list (host-to-hbo host) port protocol)))
71 (when (and local-bind-p (or local-host-p local-port-p))
72 (nconc args (list :local-host (when local-host
73 (host-to-hbo local-host))
74 :local-port local-port)))
75 (with-mapped-conditions (socket)
76 (apply #'ext:connect-to-inet-socket args))))
77 (if socket
78 (let* ((stream (sys:make-fd-stream socket :input t :output t
79 :element-type element-type
80 :buffering :full))
81 ;;###FIXME the above line probably needs an :external-format
82 (usocket (make-stream-socket :socket socket
83 :stream stream)))
84 usocket)
85 (let ((err (unix:unix-errno)))
86 (when err (cmucl-map-socket-error err)))))
87 (:datagram
88 (setf socket
89 (if (and host port)
90 (let ((args (list (host-to-hbo host) port protocol)))
91 (when (and local-bind-p (or local-host-p local-port-p))
92 (nconc args (list :local-host (when local-host
93 (host-to-hbo local-host))
94 :local-port local-port)))
95 (with-mapped-conditions (socket)
96 (apply #'ext:connect-to-inet-socket args)))
97 (if (or local-host-p local-port-p)
98 (with-mapped-conditions (socket)
99 (apply #'ext:create-inet-listener
100 (nconc (list (or local-port 0) protocol)
101 (when (and local-host-p
102 (ip/= local-host *wildcard-host*))
103 (list :host (host-to-hbo local-host))))))
104 (with-mapped-conditions (socket)
105 (ext:create-inet-socket protocol)))))
106 (if socket
107 (let ((usocket (make-datagram-socket socket :connected-p (and host port t))))
108 (ext:finalize usocket #'(lambda () (when (%open-p usocket)
109 (ext:close-socket socket))))
110 usocket)
111 (let ((err (unix:unix-errno)))
112 (when err (cmucl-map-socket-error err))))))))
113
114 (defun socket-listen (host port
115 &key reuseaddress
116 (reuse-address nil reuse-address-supplied-p)
117 (backlog 5)
118 (element-type 'character))
119 (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
120 (server-sock
121 (with-mapped-conditions ()
122 (apply #'ext:create-inet-listener
123 (nconc (list port :stream
124 :backlog backlog
125 :reuse-address reuseaddress)
126 (when (ip/= host *wildcard-host*)
127 (list :host
128 (host-to-hbo host))))))))
129 (make-stream-server-socket server-sock :element-type element-type)))
130
131 (defmethod socket-accept ((usocket stream-server-usocket) &key element-type)
132 (with-mapped-conditions (usocket)
133 (let* ((sock (ext:accept-tcp-connection (socket usocket)))
134 (stream (sys:make-fd-stream sock :input t :output t
135 :element-type (or element-type
136 (element-type usocket))
137 :buffering :full)))
138 (make-stream-socket :socket sock :stream stream))))
139
140 ;; Sockets and socket streams are represented
141 ;; by different objects. Be sure to close the
142 ;; socket stream when closing a stream socket.
143 (defmethod socket-close ((usocket stream-usocket))
144 "Close socket."
145 (when (wait-list usocket)
146 (remove-waiter (wait-list usocket) usocket))
147 (with-mapped-conditions (usocket)
148 (close (socket-stream usocket))))
149
150 (defmethod socket-close ((usocket usocket))
151 "Close socket."
152 (when (wait-list usocket)
153 (remove-waiter (wait-list usocket) usocket))
154 (with-mapped-conditions (usocket)
155 (ext:close-socket (socket usocket))))
156
157 (defmethod socket-close :after ((socket datagram-usocket))
158 (setf (%open-p socket) nil))
159
160 #+unicode
161 (defun %unix-send (fd buffer length flags)
162 (alien:alien-funcall
163 (alien:extern-alien "send"
164 (function c-call:int
165 c-call:int
166 system:system-area-pointer
167 c-call:int
168 c-call:int))
169 fd
170 (system:vector-sap buffer)
171 length
172 flags))
173
174 (defmethod socket-shutdown ((usocket usocket) direction)
175 (with-mapped-conditions (usocket)
176 (ext:inet-shutdown (socket usocket) (ecase direction
177 (:input ext:shut-rd)
178 (:output ext:shut-wr)))))
179
180 (defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0)
181 &aux (real-buffer (if (zerop offset)
182 buffer
183 (subseq buffer offset (+ offset size)))))
184 (with-mapped-conditions (usocket)
185 (if (and host port)
186 (ext:inet-sendto (socket usocket) real-buffer size (host-to-hbo host) port)
187 #-unicode
188 (unix:unix-send (socket usocket) real-buffer size 0)
189 #+unicode
190 (%unix-send (socket usocket) real-buffer size 0))))
191
192 (defmethod socket-receive ((usocket datagram-usocket) buffer length &key)
193 (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer
194 (integer 0) ; size
195 (unsigned-byte 32) ; host
196 (unsigned-byte 16))) ; port
197 (let ((real-buffer (or buffer
198 (make-array length :element-type '(unsigned-byte 8))))
199 (real-length (or length
200 (length buffer))))
201 (multiple-value-bind (nbytes remote-host remote-port)
202 (with-mapped-conditions (usocket)
203 (ext:inet-recvfrom (socket usocket) real-buffer real-length))
204 (values real-buffer nbytes remote-host remote-port))))
205
206 (defmethod get-local-name ((usocket usocket))
207 (multiple-value-bind
208 (address port)
209 (ext:get-socket-host-and-port (socket usocket))
210 (values (hbo-to-vector-quad address) port)))
211
212 (defmethod get-peer-name ((usocket stream-usocket))
213 (multiple-value-bind
214 (address port)
215 (ext:get-peer-host-and-port (socket usocket))
216 (values (hbo-to-vector-quad address) port)))
217
218 (defmethod get-local-address ((usocket usocket))
219 (nth-value 0 (get-local-name usocket)))
220
221 (defmethod get-peer-address ((usocket stream-usocket))
222 (nth-value 0 (get-peer-name usocket)))
223
224 (defmethod get-local-port ((usocket usocket))
225 (nth-value 1 (get-local-name usocket)))
226
227 (defmethod get-peer-port ((usocket stream-usocket))
228 (nth-value 1 (get-peer-name usocket)))
229
230
231 (defun lookup-host-entry (host)
232 (multiple-value-bind
233 (entry errno)
234 (ext:lookup-host-entry host)
235 (if entry
236 entry
237 ;;###The constants below work on *most* OSes, but are defined as the
238 ;; constants mentioned in C
239 (let ((exception
240 (second (assoc errno
241 '((1 ns-host-not-found-error) ;; HOST_NOT_FOUND
242 (2 ns-no-recovery-error) ;; NO_DATA
243 (3 ns-no-recovery-error) ;; NO_RECOVERY
244 (4 ns-try-again-condition)))))) ;; TRY_AGAIN
245 (when exception
246 (error exception))))))
247
248
249 (defun get-host-by-address (address)
250 (handler-case (ext:host-entry-name
251 (lookup-host-entry (host-byte-order address)))
252 (condition (condition) (handle-condition condition))))
253
254 (defun get-hosts-by-name (name)
255 (handler-case (mapcar #'hbo-to-vector-quad
256 (ext:host-entry-addr-list
257 (lookup-host-entry name)))
258 (condition (condition) (handle-condition condition))))
259
260 (defun get-host-name ()
261 (unix:unix-gethostname))
262
263 (defun %setup-wait-list (wait-list)
264 (declare (ignore wait-list)))
265
266 (defun %add-waiter (wait-list waiter)
267 (push (socket waiter) (wait-list-%wait wait-list)))
268
269 (defun %remove-waiter (wait-list waiter)
270 (setf (wait-list-%wait wait-list)
271 (remove (socket waiter) (wait-list-%wait wait-list))))
272
273 (defun wait-for-input-internal (wait-list &key timeout)
274 (with-mapped-conditions ()
275 (alien:with-alien ((rfds (alien:struct unix:fd-set)))
276 (unix:fd-zero rfds)
277 (dolist (socket (wait-list-%wait wait-list))
278 (unix:fd-set socket rfds))
279 (multiple-value-bind
280 (secs musecs)
281 (split-timeout (or timeout 1))
282 (multiple-value-bind (count err)
283 (unix:unix-fast-select (1+ (reduce #'max
284 (wait-list-%wait wait-list)))
285 (alien:addr rfds) nil nil
286 (when timeout secs) musecs)
287 (declare (ignore err))
288 (if (<= 0 count)
289 ;; process the result...
290 (dolist (x (wait-list-waiters wait-list))
291 (when (unix:fd-isset (socket x) rfds)
292 (setf (state x) :READ)))
293 (progn
294 ;;###FIXME generate an error, except for EINTR
295 )))))))