ecl.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) LICENSE
---
ecl.lisp (5141B)
---
1 ;;;; -*- Mode: Lisp -*-
2
3 ;;;; Foreign functions defined by ECL's DFFI, used for #+ecl-bytecmp only.
4 ;;;; See LICENSE for licensing information.
5
6 (in-package :usocket)
7
8 #+(and ecl-bytecmp windows)
9 (eval-when (:load-toplevel :execute)
10 (ffi:load-foreign-library "ws2_32.dll" :module "ws2_32"))
11
12 #+(and ecl-bytecmp windows)
13 (progn
14 (ffi:def-function ("gethostname" c-gethostname)
15 ((name (* :unsigned-char))
16 (len :int))
17 :returning :int
18 :module "ws2_32")
19
20 (defun get-host-name ()
21 "Returns the hostname"
22 (ffi:with-foreign-object (name '(:array :unsigned-char 256))
23 (when (zerop (c-gethostname (ffi:char-array-to-pointer name) 256))
24 (ffi:convert-from-foreign-string name))))
25
26 (ffi:def-foreign-type ws-socket :unsigned-int)
27 (ffi:def-foreign-type ws-dword :unsigned-long)
28 (ffi:def-foreign-type ws-event :unsigned-int)
29
30 (ffi:def-struct wsa-network-events
31 (network-events :long)
32 (error-code (:array :int 10)))
33
34 (ffi:def-function ("WSACreateEvent" wsa-event-create)
35 ()
36 :returning ws-event
37 :module "ws2_32")
38
39 (ffi:def-function ("WSACloseEvent" c-wsa-event-close)
40 ((event-object ws-event))
41 :returning :int
42 :module "ws2_32")
43
44 (defun wsa-event-close (ws-event)
45 (not (zerop (c-wsa-event-close ws-event))))
46
47 (ffi:def-function ("WSAEnumNetworkEvents" wsa-enum-network-events)
48 ((socket ws-socket)
49 (event-object ws-event)
50 (network-events (* wsa-network-events)))
51 :returning :int
52 :module "ws2_32")
53
54 (ffi:def-function ("WSAEventSelect" wsa-event-select)
55 ((socket ws-socket)
56 (event-object ws-event)
57 (network-events :long))
58 :returning :int
59 :module "ws2_32")
60
61 (ffi:def-function ("WSAWaitForMultipleEvents" c-wsa-wait-for-multiple-events)
62 ((number-of-events ws-dword)
63 (events (* ws-event))
64 (wait-all-p :int)
65 (timeout ws-dword)
66 (alertable-p :int))
67 :returning ws-dword
68 :module "ws2_32")
69
70 (defun wsa-wait-for-multiple-events (number-of-events events wait-all-p timeout alertable-p)
71 (c-wsa-wait-for-multiple-events number-of-events
72 events
73 (if wait-all-p -1 0)
74 timeout
75 (if alertable-p -1 0)))
76
77 (ffi:def-function ("ioctlsocket" wsa-ioctlsocket)
78 ((socket ws-socket)
79 (cmd :long)
80 (argp (* :unsigned-long)))
81 :returning :int
82 :module "ws2_32")
83
84 (ffi:def-function ("WSAGetLastError" wsa-get-last-error)
85 ()
86 :returning :int
87 :module "ws2_32")
88
89 (defun maybe-wsa-error (rv &optional socket)
90 (unless (zerop rv)
91 (raise-usock-err (wsa-get-last-error) socket)))
92
93 (defun bytes-available-for-read (socket)
94 (ffi:with-foreign-object (int-ptr :unsigned-long)
95 (maybe-wsa-error (wsa-ioctlsocket (socket-handle socket) fionread int-ptr)
96 socket)
97 (let ((int (ffi:deref-pointer int-ptr :unsigned-long)))
98 (prog1 int
99 (when (plusp int)
100 (setf (state socket) :read))))))
101
102 (defun map-network-events (func network-events)
103 (let ((event-map (ffi:get-slot-value network-events 'wsa-network-events 'network-events))
104 (error-array (ffi:get-slot-pointer network-events 'wsa-network-events 'error-code)))
105 (unless (zerop event-map)
106 (dotimes (i fd-max-events)
107 (unless (zerop (ldb (byte 1 i) event-map))
108 (funcall func (ffi:deref-array error-array '(:array :int 10) i)))))))
109
110 (defun update-ready-and-state-slots (sockets)
111 (dolist (socket sockets)
112 (if (%ready-p socket)
113 (progn
114 (setf (state socket) :READ))
115 (ffi:with-foreign-object (network-events 'wsa-network-events)
116 (let ((rv (wsa-enum-network-events (socket-handle socket) 0 network-events)))
117 (if (zerop rv)
118 (map-network-events
119 #'(lambda (err-code)
120 (if (zerop err-code)
121 (progn
122 (setf (state socket) :READ)
123 (when (stream-server-usocket-p socket)
124 (setf (%ready-p socket) t)))
125 (raise-usock-err err-code socket)))
126 network-events)
127 (maybe-wsa-error rv socket)))))))
128
129 (defun os-wait-list-%wait (wait-list)
130 (ffi:deref-pointer (wait-list-%wait wait-list) 'ws-event))
131
132 (defun (setf os-wait-list-%wait) (value wait-list)
133 (setf (ffi:deref-pointer (wait-list-%wait wait-list) 'ws-event) value))
134
135 (defun free-wait-list (wl)
136 (when (wait-list-p wl)
137 (unless (null (wait-list-%wait wl))
138 (wsa-event-close (os-wait-list-%wait wl))
139 (ffi:free-foreign-object (wait-list-%wait wl))
140 (setf (wait-list-%wait wl) nil))))
141
142 (defun %setup-wait-list (wait-list)
143 (setf (wait-list-%wait wait-list)
144 (ffi:allocate-foreign-object 'ws-event))
145 (setf (os-wait-list-%wait wait-list)
146 (wsa-event-create))
147 (ext:set-finalizer wait-list #'free-wait-list))
148
149 (defun os-socket-handle (usocket)
150 (socket-handle usocket))
151
152 ) ; #+(and ecl-bytecmp windows)