Introduction
Introduction Statistics Contact Development Disclaimer Help
topenmcl.lisp - clic - Clic is an command line interactive client for gopher wr…
git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
Log
Files
Refs
Tags
LICENSE
---
topenmcl.lisp (10498B)
---
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)
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 nil)
77 (signal nameserver-error :host-or-ip nil))
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 ()
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 ()
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 (when (wait-list usocket)
156 (remove-waiter (wait-list usocket) usocket))
157 (with-mapped-conditions (usocket)
158 (close (socket usocket))))
159
160 (defmethod socket-shutdown ((usocket usocket) direction)
161 (with-mapped-conditions (usocket)
162 (openmcl-socket:shutdown (socket usocket) :direction direction)))
163
164 #-ipv6
165 (defmethod socket-send ((usocket datagram-usocket) buffer size &key host…
166 (with-mapped-conditions (usocket)
167 (if (and host port)
168 (openmcl-socket:send-to (socket usocket) buffer size
169 :remote-host (host-to-hbo host)
170 :remote-port port
171 :offset offset)
172 ;; Clozure CL's socket function SEND-TO doesn't support operatio…
173 ;; so we have to define our own.
174 (let* ((socket (socket usocket))
175 (fd (ccl::socket-device socket)))
176 (multiple-value-setq (buffer offset)
177 (ccl::verify-socket-buffer buffer offset size))
178 (ccl::%stack-block ((bufptr size))
179 (ccl::%copy-ivector-to-ptr buffer offset bufptr 0 size)
180 (ccl::socket-call socket "send"
181 (ccl::with-eagain fd :output
182 (ccl::ignoring-eintr
183 (ccl::check-socket-error (#_send fd bufptr size 0)))))…
184
185 (defmethod socket-receive ((usocket datagram-usocket) buffer length &key)
186 (with-mapped-conditions (usocket)
187 (openmcl-socket:receive-from (socket usocket) length :buffer buffer)…
188
189 (defun usocket-host-address (address)
190 (cond
191 ((integerp address)
192 (hbo-to-vector-quad address))
193 ((and (arrayp address)
194 (= (length address) 16)
195 (every #'= address #(0 0 0 0 0 0 0 0 0 0 #xff #xff)))
196 (make-array 4 :displaced-to address :displaced-index-offset 12))
197 (t
198 address)))
199
200 (defmethod get-local-address ((usocket usocket))
201 (usocket-host-address (openmcl-socket:local-host (socket usocket))))
202
203 (defmethod get-peer-address ((usocket stream-usocket))
204 (usocket-host-address (openmcl-socket:remote-host (socket usocket))))
205
206 (defmethod get-local-port ((usocket usocket))
207 (openmcl-socket:local-port (socket usocket)))
208
209 (defmethod get-peer-port ((usocket stream-usocket))
210 (openmcl-socket:remote-port (socket usocket)))
211
212 (defmethod get-local-name ((usocket usocket))
213 (values (get-local-address usocket)
214 (get-local-port usocket)))
215
216 (defmethod get-peer-name ((usocket stream-usocket))
217 (values (get-peer-address usocket)
218 (get-peer-port usocket)))
219
220 (defun get-host-by-address (address)
221 (with-mapped-conditions ()
222 (openmcl-socket:ipaddr-to-hostname (host-to-hbo address))))
223
224 (defun get-hosts-by-name (name)
225 (with-mapped-conditions ()
226 (list (hbo-to-vector-quad (openmcl-socket:lookup-hostname
227 (host-to-hostname name))))))
228
229 (defun %setup-wait-list (wait-list)
230 (declare (ignore wait-list)))
231
232 (defun %add-waiter (wait-list waiter)
233 (declare (ignore wait-list waiter)))
234
235 (defun %remove-waiter (wait-list waiter)
236 (declare (ignore wait-list waiter)))
237
238 (defun wait-for-input-internal (wait-list &key timeout)
239 (with-mapped-conditions ()
240 (let* ((ticks-timeout (truncate (* (or timeout 1)
241 ccl::*ticks-per-second*))))
242 (input-available-p (wait-list-waiters wait-list)
243 (when timeout ticks-timeout))
244 wait-list)))
245
246 ;;; Helper functions for option.lisp
247
248 (defun get-socket-option-reuseaddr (socket)
249 (ccl::int-getsockopt (ccl::socket-device socket)
250 #$SOL_SOCKET #$SO_REUSEADDR))
251
252 (defun set-socket-option-reuseaddr (socket value)
253 (ccl::int-setsockopt (ccl::socket-device socket)
254 #$SOL_SOCKET #$SO_REUSEADDR value))
255
256 (defun get-socket-option-broadcast (socket)
257 (ccl::int-getsockopt (ccl::socket-device socket)
258 #$SOL_SOCKET #$SO_BROADCAST))
259
260 (defun set-socket-option-broadcast (socket value)
261 (ccl::int-setsockopt (ccl::socket-device socket)
262 #$SOL_SOCKET #$SO_BROADCAST value))
263
264 (defun get-socket-option-tcp-nodelay (socket)
265 (ccl::int-getsockopt (ccl::socket-device socket)
266 #$IPPROTO_TCP #$TCP_NODELAY))
267
268 (defun set-socket-option-tcp-nodelay (socket value)
269 (ccl::int-setsockopt (ccl::socket-device socket)
270 #$IPPROTO_TCP #$TCP_NODELAY value))
You are viewing proxied material from bitreich.org. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.