scl.lisp - clic - Clic is an command line interactive client for gopher written… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
scl.lisp (10025B) | |
--- | |
1 ;;;; See LICENSE for licensing information. | |
2 | |
3 (in-package :usocket) | |
4 | |
5 (defparameter +scl-error-map+ | |
6 (append +unix-errno-condition-map+ | |
7 +unix-errno-error-map+)) | |
8 | |
9 (defun scl-map-socket-error (err &key condition socket) | |
10 (let ((usock-err (cdr (assoc err +scl-error-map+ :test #'member)))) | |
11 (cond (usock-err | |
12 (if (subtypep usock-err 'error) | |
13 (error usock-err :socket socket) | |
14 (signal usock-err :socket socket))) | |
15 (t | |
16 (error 'unknown-error | |
17 :socket socket | |
18 :real-error condition))))) | |
19 | |
20 (defun handle-condition (condition &optional (socket nil) (host-or-ip ni… | |
21 "Dispatch correct usocket condition." | |
22 (typecase condition | |
23 (ext::socket-error | |
24 (scl-map-socket-error (ext::socket-errno condition) | |
25 :socket socket | |
26 :condition condition)))) | |
27 | |
28 (defun socket-connect (host port &key (protocol :stream) (element-type '… | |
29 timeout deadline (nodelay t nodelay-specified) | |
30 (local-host nil local-host-p) | |
31 (local-port nil local-port-p) | |
32 &aux | |
33 (patch-udp-p (fboundp 'ext::inet-socket-send-to))) | |
34 (when (and nodelay-specified | |
35 (not (eq nodelay :if-supported))) | |
36 (unsupported 'nodelay 'socket-connect)) | |
37 (when deadline (unsupported 'deadline 'socket-connect)) | |
38 (when timeout (unsupported 'timeout 'socket-connect)) | |
39 (when (and local-host-p (not patch-udp-p)) | |
40 (unsupported 'local-host 'socket-connect :minimum "1.3.9")) | |
41 (when (and local-port-p (not patch-udp-p)) | |
42 (unsupported 'local-port 'socket-connect :minimum "1.3.9")) | |
43 | |
44 (let ((socket)) | |
45 (ecase protocol | |
46 (:stream | |
47 (setf socket (let ((args (list (host-to-hbo host) port :kind prot… | |
48 (when (and patch-udp-p (or local-host-p local-port… | |
49 (nconc args (list :local-host (when local-host | |
50 (host-to-hbo loc… | |
51 :local-port local-port))) | |
52 (with-mapped-conditions (socket) | |
53 (apply #'ext:connect-to-inet-socket args)))) | |
54 (let ((stream (sys:make-fd-stream socket :input t :output t | |
55 :element-type element-type | |
56 :buffering :full))) | |
57 (make-stream-socket :socket socket :stream stream))) | |
58 (:datagram | |
59 (when (not patch-udp-p) | |
60 (error 'unsupported | |
61 :feature '(protocol :datagram) | |
62 :context 'socket-connect | |
63 :minumum "1.3.9")) | |
64 (setf socket | |
65 (if (and host port) | |
66 (let ((args (list (host-to-hbo host) port :kind protoco… | |
67 (when (and patch-udp-p (or local-host-p local-port-p)) | |
68 (nconc args (list :local-host (when local-host | |
69 (host-to-hbo local-… | |
70 :local-port local-port))) | |
71 (with-mapped-conditions (socket) | |
72 (apply #'ext:connect-to-inet-socket args))) | |
73 (if (or local-host-p local-port-p) | |
74 (with-mapped-conditions () | |
75 (ext:create-inet-listener (or local-port 0) | |
76 protocol | |
77 :host (when local-host | |
78 (if (ip= local-… | |
79 0 | |
80 (host-to-hb… | |
81 (with-mapped-conditions () | |
82 (ext:create-inet-socket protocol))))) | |
83 (let ((usocket (make-datagram-socket socket :connected-p (and hos… | |
84 (ext:finalize usocket #'(lambda () | |
85 (when (%open-p usocket) | |
86 (ext:close-socket socket)))) | |
87 usocket))))) | |
88 | |
89 (defun socket-listen (host port | |
90 &key reuseaddress | |
91 (reuse-address nil reuse-address-supplied-p) | |
92 (backlog 5) | |
93 (element-type 'character)) | |
94 (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reusea… | |
95 (host (if (ip= host *wildcard-host*) | |
96 0 | |
97 (host-to-hbo host))) | |
98 (server-sock | |
99 (with-mapped-conditions () | |
100 (ext:create-inet-listener port :stream | |
101 :host host | |
102 :reuse-address reuseaddress | |
103 :backlog backlog)))) | |
104 (make-stream-server-socket server-sock :element-type element-type))) | |
105 | |
106 (defmethod socket-accept ((usocket stream-server-usocket) &key element-t… | |
107 (with-mapped-conditions (usocket) | |
108 (let* ((sock (ext:accept-tcp-connection (socket usocket))) | |
109 (stream (sys:make-fd-stream sock :input t :output t | |
110 :element-type (or element-type | |
111 (element-type us… | |
112 :buffering :full))) | |
113 (make-stream-socket :socket sock :stream stream)))) | |
114 | |
115 ;; Sockets and their associated streams are modelled as | |
116 ;; different objects. Be sure to close the socket stream | |
117 ;; when closing stream-sockets; it makes sure buffers | |
118 ;; are flushed and the socket is closed correctly afterwards. | |
119 (defmethod socket-close ((usocket usocket)) | |
120 "Close socket." | |
121 (with-mapped-conditions (usocket) | |
122 (ext:close-socket (socket usocket)))) | |
123 | |
124 (defmethod socket-close ((usocket stream-usocket)) | |
125 "Close socket." | |
126 (with-mapped-conditions (usocket) | |
127 (close (socket-stream usocket)))) | |
128 | |
129 (defmethod socket-close :after ((socket datagram-usocket)) | |
130 (setf (%open-p socket) nil)) | |
131 | |
132 (defmethod socket-shutdown ((usocket usocket) direction) | |
133 (declare (ignore usocket direction)) | |
134 (unsupported "shutdown" 'socket-shutdown)) | |
135 | |
136 (defmethod socket-send ((usocket datagram-usocket) buffer size &key host… | |
137 (let ((s (socket usocket)) | |
138 (host (if host (host-to-hbo host))) | |
139 (real-buffer (if (zerop offset) | |
140 buffer | |
141 (subseq buffer offset (+ offset size))))) | |
142 (multiple-value-bind (result errno) | |
143 (ext:inet-socket-send-to s real-buffer size | |
144 :remote-host host :remote-port port) | |
145 (or result | |
146 (scl-map-socket-error errno :socket usocket))))) | |
147 | |
148 (defmethod socket-receive ((socket datagram-usocket) buffer length &key) | |
149 (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer | |
150 (integer 0) ; size | |
151 (unsigned-byte 32) ; host | |
152 (unsigned-byte 16))) ; port | |
153 (let ((s (socket socket))) | |
154 (let ((real-buffer (or buffer | |
155 (make-array length :element-type '(unsigned-b… | |
156 (real-length (or length | |
157 (length buffer)))) | |
158 (multiple-value-bind (result errno remote-host remote-port) | |
159 (ext:inet-socket-receive-from s real-buffer real-length) | |
160 (if result | |
161 (values real-buffer result remote-host remote-port) | |
162 (scl-map-socket-error errno :socket socket)))))) | |
163 | |
164 (defmethod get-local-name ((usocket usocket)) | |
165 (multiple-value-bind (address port) | |
166 (with-mapped-conditions (usocket) | |
167 (ext:get-socket-host-and-port (socket usocket))) | |
168 (values (hbo-to-vector-quad address) port))) | |
169 | |
170 (defmethod get-peer-name ((usocket stream-usocket)) | |
171 (multiple-value-bind (address port) | |
172 (with-mapped-conditions (usocket) | |
173 (ext:get-peer-host-and-port (socket usocket))) | |
174 (values (hbo-to-vector-quad address) port))) | |
175 | |
176 (defmethod get-local-address ((usocket usocket)) | |
177 (nth-value 0 (get-local-name usocket))) | |
178 | |
179 (defmethod get-peer-address ((usocket stream-usocket)) | |
180 (nth-value 0 (get-peer-name usocket))) | |
181 | |
182 (defmethod get-local-port ((usocket usocket)) | |
183 (nth-value 1 (get-local-name usocket))) | |
184 | |
185 (defmethod get-peer-port ((usocket stream-usocket)) | |
186 (nth-value 1 (get-peer-name usocket))) | |
187 | |
188 | |
189 (defun get-host-by-address (address) | |
190 (multiple-value-bind (host errno) | |
191 (ext:lookup-host-entry (host-byte-order address)) | |
192 (cond (host | |
193 (ext:host-entry-name host)) | |
194 (t | |
195 (let ((condition (cdr (assoc errno +unix-ns-error-map+)))) | |
196 (cond (condition | |
197 (error condition :host-or-ip address)) | |
198 (t | |
199 (error 'ns-unknown-error :host-or-ip address | |
200 :real-error errno)))))))) | |
201 | |
202 (defun get-hosts-by-name (name) | |
203 (multiple-value-bind (host errno) | |
204 (ext:lookup-host-entry name) | |
205 (cond (host | |
206 (mapcar #'hbo-to-vector-quad | |
207 (ext:host-entry-addr-list host))) | |
208 (t | |
209 (let ((condition (cdr (assoc errno +unix-ns-error-map+)))) | |
210 (cond (condition | |
211 (error condition :host-or-ip name)) | |
212 (t | |
213 (error 'ns-unknown-error :host-or-ip name | |
214 :real-error errno)))))))) | |
215 | |
216 (defun get-host-name () | |
217 (unix:unix-gethostname)) | |
218 | |
219 | |
220 ;; | |
221 ;; | |
222 ;; WAIT-LIST part | |
223 ;; | |
224 | |
225 | |
226 (defun %add-waiter (wl waiter) | |
227 (declare (ignore wl waiter))) | |
228 | |
229 (defun %remove-waiter (wl waiter) | |
230 (declare (ignore wl waiter))) | |
231 | |
232 (defun %setup-wait-list (wl) | |
233 (declare (ignore wl))) | |
234 | |
235 (defun wait-for-input-internal (wait-list &key timeout) | |
236 (let* ((sockets (wait-list-waiters wait-list)) | |
237 (pollfd-size (alien:alien-size (alien:struct unix::pollfd) :byt… | |
238 (nfds (length sockets)) | |
239 (bytes (* nfds pollfd-size))) | |
240 (alien:with-bytes (fds-sap bytes) | |
241 (do ((sockets sockets (rest sockets)) | |
242 (base 0 (+ base 8))) | |
243 ((endp sockets)) | |
244 (let ((fd (socket (first sockets)))) | |
245 (setf (sys:sap-ref-32 fds-sap base) fd) | |
246 (setf (sys:sap-ref-16 fds-sap (+ base 4)) unix::pollin))) | |
247 (multiple-value-bind (result errno) | |
248 (let ((thread:*thread-whostate* "Poll wait") | |
249 (timeout (if timeout | |
250 (truncate (* timeout 1000)) | |
251 -1))) | |
252 (declare (inline unix:unix-poll)) | |
253 (unix:unix-poll (alien:sap-alien fds-sap | |
254 (* (alien:struct unix::pollf… | |
255 nfds timeout)) | |
256 (cond ((not result) | |
257 (error "~@<Polling error: ~A~:@>" | |
258 (unix:get-unix-error-msg errno))) | |
259 (t | |
260 (do ((sockets sockets (rest sockets)) | |
261 (base 0 (+ base 8))) | |
262 ((endp sockets)) | |
263 (let ((flags (sys:sap-ref-16 fds-sap (+ base 6)))) | |
264 (unless (zerop (logand flags unix::pollin)) | |
265 (setf (state (first sockets)) :READ)))))))))) | |
266 |