Introduction
Introduction Statistics Contact Development Disclaimer Help
tallegro.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
---
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 '…
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-host…
72 :remote-port port
73 :local-host (when local-ho…
74 (host-to-hos…
75 :local-port local-port
76 :format (to-format element…
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…
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 ho…
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 reusea…
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-ty…
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…
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 tha…
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)))
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.