ecl.lisp - clic - Clic is an command line interactive client for gopher written… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
ecl.lisp (5141B) | |
--- | |
1 ;;;; -*- Mode: Lisp -*- | |
2 | |
3 ;;;; Foreign functions defined by ECL's DFFI, used for #+ecl-bytecmp onl… | |
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-… | |
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-… | |
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 … | |
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-eve… | |
104 (error-array (ffi:get-slot-pointer network-events 'wsa-network… | |
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)… | |
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 ne… | |
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) valu… | |
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) |