GopherProxy

	tecl.lisp - clic - Clic is an command line interactive client for gopher writte…
	git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
	Log
	Files
	Refs
	Tags
	LICENSE
	---
	tecl.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)