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