tallegro.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
---
tallegro.lisp (8336B)
---
1 ;;;; See LICENSE for licensing information.
2
3 (in-package :usocket)
4
5 #+cormanlisp
6 (eval-when (:compile-toplevel :load-toplevel :execute)
7 (require :acl-socket))
8
9 #+allegro
10 (eval-when (:compile-toplevel :load-toplevel :execute)
11 (require :sock)
12 ;; for wait-for-input:
13 (require :process)
14 ;; note: the line below requires ACL 6.2+
15 (require :osi))
16
17 (defun get-host-name ()
18 ;; note: the line below requires ACL 7.0+ to actually *work* on windows
19 #+allegro (excl.osi:gethostname)
20 #+cormanlisp "")
21
22 (defparameter +allegro-identifier-error-map+
23 '((:address-in-use . address-in-use-error)
24 (:address-not-available . address-not-available-error)
25 (:network-down . network-down-error)
26 (:network-reset . network-reset-error)
27 (:network-unreachable . network-unreachable-error)
28 (:connection-aborted . connection-aborted-error)
29 (:connection-reset . connection-reset-error)
30 (:no-buffer-space . no-buffers-error)
31 (:shutdown . shutdown-error)
32 (:connection-timed-out . timeout-error)
33 (:connection-refused . connection-refused-error)
34 (:host-down . host-down-error)
35 (:host-unreachable . host-unreachable-error)))
36
37 (defun handle-condition (condition &optional (socket nil))
38 "Dispatch correct usocket condition."
39 (typecase condition
40 #+allegro
41 (excl:socket-error
42 (let ((usock-err
43 (cdr (assoc (excl:stream-error-identifier condition)
44 +allegro-identifier-error-map+))))
45 (if usock-err
46 (error usock-err :socket socket)
47 (error 'unknown-error
48 :real-error condition
49 :socket socket))))))
50
51 (defun to-format (element-type)
52 (if (subtypep element-type 'character)
53 :text
54 :binary))
55
56 (defun socket-connect (host port &key (protocol :stream) (element-type 'character)
57 timeout deadline
58 (nodelay t) ;; nodelay == t is the ACL default
59 local-host local-port)
60 (when timeout (unsupported 'timeout 'socket-connect))
61 (when deadline (unsupported 'deadline 'socket-connect))
62 (when (eq nodelay :if-supported)
63 (setf nodelay t))
64
65 (let ((socket))
66 (setf socket
67 (with-mapped-conditions (socket)
68 (ecase protocol
69 (:stream
70 (labels ((make-socket ()
71 (socket:make-socket :remote-host (host-to-hostname host)
72 :remote-port port
73 :local-host (when local-host
74 (host-to-hostname local-host))
75 :local-port local-port
76 :format (to-format element-type)
77 :nodelay nodelay)))
78 #+allegro
79 (if timeout
80 (mp:with-timeout (timeout nil)
81 (make-socket))
82 (make-socket))
83 #+cormanlisp (make-socket)))
84 (:datagram
85 (apply #'socket:make-socket
86 (nconc (list :type protocol
87 :address-family :internet
88 :local-host (when local-host
89 (host-to-hostname local-host))
90 :local-port local-port
91 :format (to-format element-type))
92 (if (and host port)
93 (list :connect :active
94 :remote-host (host-to-hostname host)
95 :remote-port port)
96 (list :connect :passive))))))))
97 (ecase protocol
98 (:stream
99 (make-stream-socket :socket socket :stream socket))
100 (:datagram
101 (make-datagram-socket socket :connected-p (and host port t))))))
102
103 ;; One socket close method is sufficient,
104 ;; because socket-streams are also sockets.
105 (defmethod socket-close ((usocket usocket))
106 "Close socket."
107 (when (wait-list usocket)
108 (remove-waiter (wait-list usocket) usocket))
109 (with-mapped-conditions (usocket)
110 (close (socket usocket))))
111
112 (defmethod socket-shutdown ((usocket stream-usocket) direction)
113 (with-mapped-conditions (usocket)
114 (socket:shutdown (socket usocket) :direction direction)))
115
116 (defun socket-listen (host port
117 &key reuseaddress
118 (reuse-address nil reuse-address-supplied-p)
119 (backlog 5)
120 (element-type 'character))
121 ;; Allegro and OpenMCL socket interfaces bear very strong resemblence
122 ;; whatever you change here, change it also for OpenMCL
123 (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reuseaddress))
124 (sock (with-mapped-conditions ()
125 (apply #'socket:make-socket
126 (append (list :connect :passive
127 :reuse-address reuseaddress
128 :local-port port
129 :backlog backlog
130 :format (to-format element-type)
131 ;; allegro now ignores :format
132 )
133 (when (ip/= host *wildcard-host*)
134 (list :local-host host)))))))
135 (make-stream-server-socket sock :element-type element-type)))
136
137 (defmethod socket-accept ((socket stream-server-usocket) &key element-type)
138 (declare (ignore element-type)) ;; allegro streams are multivalent
139 (let ((stream-sock
140 (with-mapped-conditions (socket)
141 (socket:accept-connection (socket socket)))))
142 (make-stream-socket :socket stream-sock :stream stream-sock)))
143
144 (defmethod get-local-address ((usocket usocket))
145 (hbo-to-vector-quad (socket:local-host (socket usocket))))
146
147 (defmethod get-peer-address ((usocket stream-usocket))
148 (hbo-to-vector-quad (socket:remote-host (socket usocket))))
149
150 (defmethod get-local-port ((usocket usocket))
151 (socket:local-port (socket usocket)))
152
153 (defmethod get-peer-port ((usocket stream-usocket))
154 #+allegro
155 (socket:remote-port (socket usocket)))
156
157 (defmethod get-local-name ((usocket usocket))
158 (values (get-local-address usocket)
159 (get-local-port usocket)))
160
161 (defmethod get-peer-name ((usocket stream-usocket))
162 (values (get-peer-address usocket)
163 (get-peer-port usocket)))
164
165 #+allegro
166 (defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0))
167 (with-mapped-conditions (usocket)
168 (let ((s (socket usocket)))
169 (socket:send-to s
170 (if (zerop offset)
171 buffer
172 (subseq buffer offset (+ offset size)))
173 size
174 :remote-host host
175 :remote-port port))))
176
177 #+allegro
178 (defmethod socket-receive ((socket datagram-usocket) buffer length &key)
179 (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer
180 (integer 0) ; size
181 (unsigned-byte 32) ; host
182 (unsigned-byte 16))) ; port
183 (with-mapped-conditions (socket)
184 (let ((s (socket socket)))
185 (socket:receive-from s length :buffer buffer :extract t))))
186
187 (defun get-host-by-address (address)
188 (with-mapped-conditions ()
189 (socket:ipaddr-to-hostname (host-to-hbo address))))
190
191 (defun get-hosts-by-name (name)
192 ;;###FIXME: ACL has the acldns module which returns all A records
193 ;; only problem: it doesn't fall back to tcp (from udp) if the returned
194 ;; structure is too long.
195 (with-mapped-conditions ()
196 (list (hbo-to-vector-quad (socket:lookup-hostname
197 (host-to-hostname name))))))
198
199 (defun %setup-wait-list (wait-list)
200 (declare (ignore wait-list)))
201
202 (defun %add-waiter (wait-list waiter)
203 (push (socket waiter) (wait-list-%wait wait-list)))
204
205 (defun %remove-waiter (wait-list waiter)
206 (setf (wait-list-%wait wait-list)
207 (remove (socket waiter) (wait-list-%wait wait-list))))
208
209 #+allegro
210 (defun wait-for-input-internal (wait-list &key timeout)
211 (with-mapped-conditions ()
212 (let ((active-internal-sockets
213 (if timeout
214 (mp:wait-for-input-available (wait-list-%wait wait-list)
215 :timeout timeout)
216 (mp:wait-for-input-available (wait-list-%wait wait-list)))))
217 ;; this is quadratic, but hey, the active-internal-sockets
218 ;; list is very short and it's only quadratic in the length of that one.
219 ;; When I have more time I could recode it to something of linear
220 ;; complexity.
221 ;; [Same code is also used in openmcl.lisp]
222 (dolist (x active-internal-sockets)
223 (setf (state (gethash x (wait-list-map wait-list)))
224 :read))
225 wait-list)))