tmocl.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
---
tmocl.lisp (5640B)
---
1 ;;;; See LICENSE for licensing information.
2
3 (in-package :usocket)
4
5 (defun handle-condition (condition &optional (socket nil))
6 "Dispatch correct usocket condition."
7 (declare (ignore socket))
8 (signal condition))
9
10 (defun socket-connect (host port &key (protocol :stream) (element-type 'character)
11 timeout deadline (nodelay t nodelay-specified)
12 (local-host nil local-host-p)
13 (local-port nil local-port-p))
14 (when (and nodelay-specified
15 (not (eq nodelay :if-supported)))
16 (unsupported 'nodelay 'socket-connect))
17 (when deadline (unsupported 'deadline 'socket-connect))
18 (when timeout (unimplemented 'timeout 'socket-connect))
19 (when local-host-p
20 (unimplemented 'local-host 'socket-connect))
21 (when local-port-p
22 (unimplemented 'local-port 'socket-connect))
23
24 (let (socket)
25 (ecase protocol
26 (:stream
27 (setf socket (rt::socket-connect host port))
28 (let ((stream (rt::make-socket-stream socket :binaryp (not (eq element-type 'character)))))
29 (make-stream-socket :socket socket :stream stream)))
30 (:datagram
31 (error 'unsupported
32 :feature '(protocol :datagram)
33 :context 'socket-connect)))))
34
35 (defun socket-listen (host port
36 &key reuseaddress
37 (reuse-address nil reuse-address-supplied-p)
38 (backlog 5)
39 (element-type 'character))
40 (unimplemented 'socket-listen 'mocl))
41
42 (defmethod socket-accept ((usocket stream-server-usocket) &key element-type)
43 (unimplemented 'socket-accept 'mocl))
44
45 ;; Sockets and their associated streams are modelled as
46 ;; different objects. Be sure to close the socket stream
47 ;; when closing stream-sockets; it makes sure buffers
48 ;; are flushed and the socket is closed correctly afterwards.
49 (defmethod socket-close ((usocket usocket))
50 "Close socket."
51 (when (wait-list usocket)
52 (remove-waiter (wait-list usocket) usocket))
53 (rt::socket-shutdown usocket)
54 (rt::c-fclose usocket))
55
56 (defmethod socket-close ((usocket stream-usocket))
57 "Close socket."
58 (when (wait-list usocket)
59 (remove-waiter (wait-list usocket) usocket))
60 (close (socket-stream usocket)))
61
62 ;; (defmethod socket-close :after ((socket datagram-usocket))
63 ;; (setf (%open-p socket) nil))
64
65 (defmethod socket-shutdown ((usocket stream-usocket) direction)
66 (declare (ignore usocket direction))
67 ;; sure would be nice if there was some documentation for mocl...
68 (unimplemented "shutdown" 'socket-shutdown))
69
70 ;; (defmethod socket-send ((usocket datagram-usocket) buffer size &key host port)
71 ;; (let ((s (socket usocket))
72 ;; (host (if host (host-to-hbo host)))
73 ;; (real-buffer (if (zerop offset)
74 ;; buffer
75 ;; (subseq buffer offset (+ offset size)))))
76 ;; (multiple-value-bind (result errno)
77 ;; (ext:inet-socket-send-to s real-buffer size
78 ;; :remote-host host :remote-port port)
79 ;; (or result
80 ;; (mocl-map-socket-error errno :socket usocket)))))
81
82 ;; (defmethod socket-receive ((socket datagram-usocket) buffer length &key)
83 ;; (declare (values (simple-array (unsigned-byte 8) (*)) ; buffer
84 ;; (integer 0) ; size
85 ;; (unsigned-byte 32) ; host
86 ;; (unsigned-byte 16))) ; port
87 ;; (let ((s (socket socket)))
88 ;; (let ((real-buffer (or buffer
89 ;; (make-array length :element-type '(unsigned-byte 8))))
90 ;; (real-length (or length
91 ;; (length buffer))))
92 ;; (multiple-value-bind (result errno remote-host remote-port)
93 ;; (ext:inet-socket-receive-from s real-buffer real-length)
94 ;; (if result
95 ;; (values real-buffer result remote-host remote-port)
96 ;; (mocl-map-socket-error errno :socket socket))))))
97
98 ;; (defmethod get-local-name ((usocket usocket))
99 ;; (multiple-value-bind (address port)
100 ;; (with-mapped-conditions (usocket)
101 ;; (ext:get-socket-host-and-port (socket usocket)))
102 ;; (values (hbo-to-vector-quad address) port)))
103
104 ;; (defmethod get-peer-name ((usocket stream-usocket))
105 ;; (multiple-value-bind (address port)
106 ;; (with-mapped-conditions (usocket)
107 ;; (ext:get-peer-host-and-port (socket usocket)))
108 ;; (values (hbo-to-vector-quad address) port)))
109
110 ;; (defmethod get-local-address ((usocket usocket))
111 ;; (nth-value 0 (get-local-name usocket)))
112
113 ;; (defmethod get-peer-address ((usocket stream-usocket))
114 ;; (nth-value 0 (get-peer-name usocket)))
115
116 ;; (defmethod get-local-port ((usocket usocket))
117 ;; (nth-value 1 (get-local-name usocket)))
118
119 ;; (defmethod get-peer-port ((usocket stream-usocket))
120 ;; (nth-value 1 (get-peer-name usocket)))
121
122
123 ;; (defun get-host-by-address (address)
124 ;; (multiple-value-bind (host errno)
125 ;; (ext:lookup-host-entry (host-byte-order address))
126 ;; (cond (host
127 ;; (ext:host-entry-name host))
128 ;; (t
129 ;; (let ((condition (cdr (assoc errno +unix-ns-error-map+))))
130 ;; (cond (condition
131 ;; (error condition :host-or-ip address))
132 ;; (t
133 ;; (error 'ns-unknown-error :host-or-ip address
134 ;; :real-error errno))))))))
135
136 (defun get-hosts-by-name (name)
137 (rt::lookup-host name))
138
139 ;; (defun get-host-name ()
140 ;; (unix:unix-gethostname))
141
142
143 ;;
144 ;;
145 ;; WAIT-LIST part
146 ;;
147
148
149 (defun %add-waiter (wl waiter)
150 (declare (ignore wl waiter)))
151
152 (defun %remove-waiter (wl waiter)
153 (declare (ignore wl waiter)))
154
155 (defun %setup-wait-list (wl)
156 (declare (ignore wl)))
157
158 (defun wait-for-input-internal (wait-list &key timeout)
159 (unimplemented 'wait-for-input-internal 'mocl))