allegro.lisp - clic - Clic is an command line interactive client for gopher wri… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
allegro.lisp (8591B) | |
--- | |
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 ;; TODO: what's the error class of Corman Lisp? | |
38 (defun handle-condition (condition &optional (socket nil) (host-or-ip ni… | |
39 "Dispatch correct usocket condition." | |
40 (typecase condition | |
41 #+allegro | |
42 (excl:socket-error | |
43 (let ((usock-error | |
44 (cdr (assoc (excl:stream-error-identifier condition) | |
45 +allegro-identifier-error-map+)))) | |
46 (declare (type symbol usock-error)) | |
47 (if usock-error | |
48 (cond ((subtypep usock-error 'ns-error) | |
49 (error usock-error :socket socket :host-or-ip host-or-… | |
50 (t | |
51 (error usock-error :socket socket))) | |
52 (error 'unknown-error | |
53 :real-error condition | |
54 :socket socket)))))) | |
55 | |
56 (defun to-format (element-type) | |
57 (if (subtypep element-type 'character) | |
58 :text | |
59 :binary)) | |
60 | |
61 (defun socket-connect (host port &key (protocol :stream) (element-type '… | |
62 timeout deadline | |
63 (nodelay t) ;; nodelay == t is the ACL default | |
64 local-host local-port) | |
65 (when timeout (unsupported 'timeout 'socket-connect)) | |
66 (when deadline (unsupported 'deadline 'socket-connect)) | |
67 (when (eq nodelay :if-supported) | |
68 (setf nodelay t)) | |
69 | |
70 (let ((socket)) | |
71 (setf socket | |
72 (with-mapped-conditions (socket (or host local-host)) | |
73 (ecase protocol | |
74 (:stream | |
75 (labels ((make-socket () | |
76 (socket:make-socket :remote-host (host-to-host… | |
77 :remote-port port | |
78 :local-host (when local-ho… | |
79 (host-to-hos… | |
80 :local-port local-port | |
81 :format (to-format element… | |
82 :nodelay nodelay))) | |
83 #+allegro | |
84 (if timeout | |
85 (mp:with-timeout (timeout nil) | |
86 (make-socket)) | |
87 (make-socket)) | |
88 #+cormanlisp (make-socket))) | |
89 (:datagram | |
90 (apply #'socket:make-socket | |
91 (nconc (list :type protocol | |
92 :address-family :internet | |
93 :local-host (when local-host | |
94 (host-to-hostname local… | |
95 :local-port local-port | |
96 :format (to-format element-type)) | |
97 (if (and host port) | |
98 (list :connect :active | |
99 :remote-host (host-to-hostname ho… | |
100 :remote-port port) | |
101 (list :connect :passive)))))))) | |
102 (ecase protocol | |
103 (:stream | |
104 (make-stream-socket :socket socket :stream socket)) | |
105 (:datagram | |
106 (make-datagram-socket socket :connected-p (and host port t)))))) | |
107 | |
108 ;; One socket close method is sufficient, | |
109 ;; because socket-streams are also sockets. | |
110 (defmethod socket-close ((usocket usocket)) | |
111 "Close socket." | |
112 (with-mapped-conditions (usocket) | |
113 (close (socket usocket)))) | |
114 | |
115 (defmethod socket-shutdown ((usocket stream-usocket) direction) | |
116 (with-mapped-conditions (usocket) | |
117 (socket:shutdown (socket usocket) :direction direction))) | |
118 | |
119 (defun socket-listen (host port | |
120 &key reuseaddress | |
121 (reuse-address nil reuse-address-supplied-p) | |
122 (backlog 5) | |
123 (element-type 'character)) | |
124 ;; Allegro and OpenMCL socket interfaces bear very strong resemblence | |
125 ;; whatever you change here, change it also for OpenMCL | |
126 (let* ((reuseaddress (if reuse-address-supplied-p reuse-address reusea… | |
127 (sock (with-mapped-conditions (nil host) | |
128 (apply #'socket:make-socket | |
129 (append (list :connect :passive | |
130 :reuse-address reuseaddress | |
131 :local-port port | |
132 :backlog backlog | |
133 :format (to-format element-type) | |
134 ;; allegro now ignores :format | |
135 ) | |
136 (when (ip/= host *wildcard-host*) | |
137 (list :local-host host))))))) | |
138 (make-stream-server-socket sock :element-type element-type))) | |
139 | |
140 (defmethod socket-accept ((socket stream-server-usocket) &key element-ty… | |
141 (declare (ignore element-type)) ;; allegro streams are multivalent | |
142 (let ((stream-sock | |
143 (with-mapped-conditions (socket) | |
144 (socket:accept-connection (socket socket))))) | |
145 (make-stream-socket :socket stream-sock :stream stream-sock))) | |
146 | |
147 (defmethod get-local-address ((usocket usocket)) | |
148 (hbo-to-vector-quad (socket:local-host (socket usocket)))) | |
149 | |
150 (defmethod get-peer-address ((usocket stream-usocket)) | |
151 (hbo-to-vector-quad (socket:remote-host (socket usocket)))) | |
152 | |
153 (defmethod get-local-port ((usocket usocket)) | |
154 (socket:local-port (socket usocket))) | |
155 | |
156 (defmethod get-peer-port ((usocket stream-usocket)) | |
157 #+allegro | |
158 (socket:remote-port (socket usocket))) | |
159 | |
160 (defmethod get-local-name ((usocket usocket)) | |
161 (values (get-local-address usocket) | |
162 (get-local-port usocket))) | |
163 | |
164 (defmethod get-peer-name ((usocket stream-usocket)) | |
165 (values (get-peer-address usocket) | |
166 (get-peer-port usocket))) | |
167 | |
168 #+allegro | |
169 (defmethod socket-send ((usocket datagram-usocket) buffer size &key host… | |
170 (with-mapped-conditions (usocket host) | |
171 (let ((s (socket usocket))) | |
172 (socket:send-to s | |
173 (if (zerop offset) | |
174 buffer | |
175 (subseq buffer offset (+ offset size))) | |
176 size | |
177 :remote-host host | |
178 :remote-port port)))) | |
179 | |
180 #+allegro | |
181 (defmethod socket-receive ((usocket datagram-usocket) buffer length &key) | |
182 (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer | |
183 (integer 0) ; size | |
184 (unsigned-byte 32) ; host | |
185 (unsigned-byte 16))) ; port | |
186 (with-mapped-conditions (usocket) | |
187 (let ((s (socket usocket))) | |
188 (socket:receive-from s length :buffer buffer :extract t)))) | |
189 | |
190 (defun get-host-by-address (address) | |
191 (with-mapped-conditions (nil address) | |
192 (socket:ipaddr-to-hostname (host-to-hbo address)))) | |
193 | |
194 (defun get-hosts-by-name (name) | |
195 ;;###FIXME: ACL has the acldns module which returns all A records | |
196 ;; only problem: it doesn't fall back to tcp (from udp) if the returned | |
197 ;; structure is too long. | |
198 (with-mapped-conditions (nil name) | |
199 (list (hbo-to-vector-quad (socket:lookup-hostname | |
200 (host-to-hostname name)))))) | |
201 | |
202 (defun %setup-wait-list (wait-list) | |
203 (declare (ignore wait-list))) | |
204 | |
205 (defun %add-waiter (wait-list waiter) | |
206 (push (socket waiter) (wait-list-%wait wait-list))) | |
207 | |
208 (defun %remove-waiter (wait-list waiter) | |
209 (setf (wait-list-%wait wait-list) | |
210 (remove (socket waiter) (wait-list-%wait wait-list)))) | |
211 | |
212 #+allegro | |
213 (defun wait-for-input-internal (wait-list &key timeout) | |
214 (with-mapped-conditions () | |
215 (let ((active-internal-sockets | |
216 (if timeout | |
217 (mp:wait-for-input-available (wait-list-%wait wait-list) | |
218 :timeout timeout) | |
219 (mp:wait-for-input-available (wait-list-%wait wait-list))))) | |
220 ;; this is quadratic, but hey, the active-internal-sockets | |
221 ;; list is very short and it's only quadratic in the length of tha… | |
222 ;; When I have more time I could recode it to something of linear | |
223 ;; complexity. | |
224 ;; [Same code is also used in openmcl.lisp] | |
225 (dolist (x active-internal-sockets) | |
226 (setf (state (gethash x (wait-list-map wait-list))) | |
227 :read)) | |
228 wait-list))) |