kqueue.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
---
kqueue.lisp (19988B)
---
1 ;;;-*-Mode: LISP; Package: CCL -*-
2 ;;
3 ;; KQUEUE.LISP
4 ;;
5 ;; KQUEUE - BSD kernel event notification mechanism support for Common LISP.
6 ;; Copyright (C) 2007 Terje Norderhaug <terje@in-progress.com>
7 ;; Released under LGPL - see <http://www.gnu.org>.
8 ;; Alternative licensing available upon request.
9 ;;
10 ;; DISCLAIMER: The user of this module should understand that executing code is a potentially hazardous
11 ;; activity, and that many dangers and obstacles, marked or unmarked, may exist within this code.
12 ;; As a condition of your use of the module, you assume all risk of personal injury, death, or property
13 ;; loss, and all other bad things that may happen, even if caused by negligence, ignorance or stupidity.
14 ;; The author is is no way responsible, and besides, does not have "deep pockets" nor any spare change.
15 ;;
16 ;; Version: 0.20 alpha (July 26, 2009) - subject to major revisions, so consider yourself warned.
17 ;; Tested with Macintosh Common LISP 5.1 and 5.2, but is intended to be platform and system independent in the future.
18 ;;
19 ;; Email feedback and improvements to <terje@in-progress.com>.
20 ;; Updated versions will be available from <http://www.in-progress.com/src/>.
21 ;;
22 ;; RELATED IMPLEMENTATIONS
23 ;; There is another kevent.lisp for other platforms by Risto Laakso (merge?).
24 ;; Also a Scheme kevent.ss by Jose Antonio Ortega.
25 ;;
26 ;; SEE ALSO:
27 ;; http://people.freebsd.org/~jlemon/papers/kqueue.pdf
28 ;; http://developer.apple.com/samplecode/FileNotification/index.html
29 ;; The Man page for kqueue() or kevent().
30 ;; PyKQueue - Python OO interface to KQueue.
31 ;; LibEvent - an event notification library in C by Niels Provos.
32 ;; Liboop - another abstract library in C on top of kevent or other kernel notification.
33
34 #| HISTORY:
35
36 2007-Oct-18 terje version 0.1 released on the Info-MCL mailing list.
37 2008-Aug-21 terje load-framework-bundle is not needed under MCL 5.2
38 2008-Aug-21 terje rename get-addr to lookup-function-in-bundle (only for pre MCL 5.2)
39 2009-Jul-19 terje uses kevent-error condition and strerror.
40 2009-Jul-24 terje reports errors unless nil-if-not-found in lookup-function-in-bundle.
41 2009-Jul-24 terje kevent :variant for C's intptr_t type for 64bit (and osx 10.5) compatibility.
42 2009-Jul-25 terje 64bit support, dynamically determined for PPC. Kudos to Glen Foy for helping out.
43 2009-Jul-25 terje make-kevent function.
44 |#
45
46 #| IMPLEMENTATION NOTES:
47
48 kevents are copied into and from the kernel, so the records don't have to be kept in the app!
49 kevents does not work in OSX before 10.3.
50 *kevent-record* has to be explcitly set to :kevent64 to work on 64bit intel macs.
51 Consider using sysctlbyname() to test for 64bit,
52 combining hw.cpu64bit_capable, hw.optional.x86_64 and hw.optional.64bitops
53 |#
54
55 (in-package :ccl)
56
57 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
58
59 #-ccl-5.2 ; has been added to MCL 5.2
60 (defmethod load-framework-bundle ((framework-name string) &key (load-executable t))
61 ;; FRAMWORK CALL FUNCTIONALITY FROM BSD.LISP
62 ;; (C) 2003 Brendan Burns <bburns@cs.umass.edu>
63 ;; Released under LGPL.
64 (with-cfstrs ((framework framework-name))
65 (let ((err 0)
66 (baseURL nil)
67 (bundleURL nil)
68 (result nil))
69 (rlet ((folder :fsref))
70 ;; Find the folder holding the bundle
71 (setf err (#_FSFindFolder #$kOnAppropriateDisk #$kFrameworksFolderType
72 t folder))
73
74 ;; if everything's cool, make a URL for it
75 (when (zerop err)
76 (setf baseURL (#_CFURLCreateFromFSRef (%null-ptr) folder))
77 (if (%null-ptr-p baseURL)
78 (setf err #$coreFoundationUnknownErr)))
79
80 ;; if everything's cool, make a URL for the bundle
81 (when (zerop err)
82 (setf bundleURL (#_CFURLCreateCopyAppendingPathComponent (%null-ptr)
83 baseURL framework nil))
84 (if (%null-ptr-p bundleURL)
85 (setf err #$coreFoundationUnknownErr)))
86
87 ;; if everything's cool, load it
88 (when (zerop err)
89 (setf result (#_CFBundleCreate (%null-ptr) bundleURL))
90 (if (%null-ptr-p result)
91 (setf err #$coreFoundationUnknownErr)))
92
93 ;; if everything's cool, and the user wants it loaded, load it
94 (when (and load-executable (zerop err))
95 (if (not (#_CFBundleLoadExecutable result))
96 (setf err #$coreFoundationUnknownErr)))
97
98 ;; if there's an error, but we've got a pointer, free it and clear result
99 (when (and (not (zerop err)) (not (%null-ptr-p result)))
100 (#_CFRelease result)
101 (setf result nil))
102
103 ;; free the URLs if there non-null
104 (when (not (%null-ptr-p bundleURL))
105 (#_CFRelease bundleURL))
106 (when (not (%null-ptr-p baseURL))
107 (#_CFRelease baseURL))
108
109 ;; return pointer + error value
110 (values result err)))))
111
112 #+ignore
113 (defun get-addr (bundle name)
114 (let* ((addr (#_CFBundleGetFunctionPointerForName bundle name)))
115 (rlet ((buf :long))
116 (setf (%get-ptr buf) addr)
117 (ash (%get-signed-long buf) -2))))
118
119 #-ccl-5.2
120 (defun lookup-function-in-bundle (name bundle &optional nil-if-not-found)
121 (with-cfstrs ((str name))
122 (let* ((addr (#_CFBundleGetFunctionPointerForName bundle str)))
123 (if (%null-ptr-p addr)
124 (unless nil-if-not-found
125 (error "Couldn't resolve address of foreign function ~s" name))
126 (rlet ((buf :long)) ;; mcl 5.2 uses %fixnum-from-macptr here
127 (setf (%get-ptr buf) addr)
128 (ash (%get-signed-long buf) -2))))))
129
130 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
131 ;; Convenient way to declare BSD system calls
132
133 #+ignore
134 (defparameter *system-bundle*
135 #+ccl-5.2 (get-bundle-for-framework-name "System.framework")
136 #-ccl-5.2
137 (let ((bundle (load-framework-bundle "System.framework")))
138 (terminate-when-unreachable bundle (lambda (b)(#_CFRelease b)))
139 bundle))
140
141 (defmacro declare-bundle-ff (name name-string &rest arglist &aux (fn (gensym (format nil "ff_~A_" (string name)))))
142 ;; Is there an existing define-trap like macro for this? or could one be modified for use with bundles?
143 `(progn
144 (defloadvar ,fn
145 (let* ((bundle #+ccl-5.2 (get-bundle-for-framework-name "System.framework")
146 #-ccl-5.2
147 (let ((bundle (load-framework-bundle "System.framework")))
148 (terminate-when-unreachable bundle (lambda (b)(#_CFRelease b)))
149 bundle)))
150 (lookup-function-in-bundle ,name-string bundle)))
151 ,(let ((args (do ((arglist arglist (cddr arglist))
152 (result))
153 ((not (cdr arglist)) (nreverse result))
154 (push (second arglist) result))))
155 `(defun ,name ,args
156 (ppc-ff-call ,fn ,@arglist)))))
157
158 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
159
160 (declare-bundle-ff %system-kqueue "kqueue"
161 :signed-fullword) ;; returns a file descriptor no!
162
163 (defun system-kqueue ()
164 (let ((kq (%system-kqueue)))
165 (if (= kq -1)
166 (ecase (%system-errno)
167 (12 (error "The kernel failed to allocate enough memory for the kernel queue")) ; ENOMEM
168 (24 (error "The per-process descriptor table is full")) ; EMFILE
169 (23 (error "The system file table is full"))) ; ENFILE
170 kq)))
171
172 (declare-bundle-ff %system-kevent "kevent"
173 :unsigned-fullword kq
174 :address ke
175 :unsigned-fullword nke
176 :address ko
177 :unsigned-fullword nko
178 :address timeout
179 :signed-fullword)
180
181 (declare-bundle-ff %system-open "open"
182 :address name
183 :unsigned-fullword mode
184 :unsigned-fullword arg
185 :signed-fullword)
186
187 (declare-bundle-ff %system-close "close"
188 :unsigned-fullword fd
189 :signed-fullword)
190
191 (declare-bundle-ff %system-errno* "__error"
192 :signed-fullword)
193
194 (declare-bundle-ff %system-strerror "strerror"
195 :signed-fullword errno
196 :address)
197
198 (defun %system-errno ()
199 (%get-fixnum (%int-to-ptr (%system-errno*))))
200
201 ; (%system-errno)
202
203 (defconstant $O-EVTONLY #x8000)
204 ; (defconstant $O-NONBLOCK #x800 "Non blocking mode")
205
206 (defun system-open (posix-namestring)
207 "Low level open function, as in C, returns an fd number"
208 (with-cstrs ((name posix-namestring))
209 (%system-open name $O-EVTONLY 0)))
210
211 (defun system-close (fd)
212 (%system-close fd))
213
214 (defrecord timespec
215 (sec :unsigned-long)
216 (usec :unsigned-long))
217
218 (defVar *kevent-record* nil)
219
220 (def-ccl-pointers determine-64bit-kevents ()
221 (setf *kevent-record*
222 (if (ccl::gestalt #$gestaltPowerPCProcessorFeatures
223 #+ccl-5.2 #$gestaltPowerPCHas64BitSupport #-ccl-5.2 6)
224 :kevent32
225 :kevent64)))
226
227 (defrecord :kevent32
228 (ident :unsigned-long) ; uintptr_t
229 (filter :short)
230 (flags :unsigned-short)
231 (fflags :unsigned-long)
232 (data :long) ; intptr_t
233 (udata :pointer))
234
235 (defrecord :kevent64
236 (:variant ; uintptr_t
237 ((ident64 :uint64))
238 ((ident :unsigned-long)))
239 (filter :short)
240 (flags :unsigned-short)
241 (fflags :unsigned-long)
242 (:variant ; intptr_t
243 ((data64 :sint64))
244 ((data :long)))
245 (:variant ; RMCL :pointer is 32bit
246 ((udata64 :uint64))
247 ((udata :pointer))))
248
249 (defun make-kevent (&key (ident 0) (filter 0) (flags 0) (fflags 0) (data 0) (udata *null-ptr*))
250 (ecase *kevent-record*
251 (:kevent64
252 (make-record kevent64
253 :ident ident
254 :filter filter
255 :flags flags
256 :fflags fflags
257 :data data
258 :udata udata))
259 (:kevent32
260 (make-record kevent32
261 :ident ident
262 :filter filter
263 :flags flags
264 :fflags fflags
265 :data data
266 :udata udata))))
267
268 (defun kevent-rref (ke field)
269 (ecase *kevent-record*
270 (:kevent32
271 (ecase field
272 (:ident (rref ke :kevent32.ident))
273 (:filter (rref ke :kevent32.filter))
274 (:flags (rref ke :kevent32.flags))
275 (:fflags (rref ke :kevent32.fflags))
276 (:data (rref ke :kevent32.data))
277 (:udata (rref ke :kevent32.udata))))
278 (:kevent64
279 (ecase field
280 (:ident (rref ke :kevent64.ident))
281 (:filter (rref ke :kevent64.filter))
282 (:flags (rref ke :kevent64.flags))
283 (:fflags (rref ke :kevent64.fflags))
284 (:data (rref ke :kevent64.data))
285 (:udata (rref ke :kevent64.udata))))))
286
287 (defun kevent-filter (ke)
288 (kevent-rref ke :filter))
289
290 (defun kevent-flags (ke)
291 (kevent-rref ke :flags))
292
293 (defun kevent-data (ke)
294 (kevent-rref ke :data))
295
296
297 ;; FILTER TYPES:
298
299 (eval-when (:compile-toplevel :load-toplevel :execute) ; added by binghe
300
301 (defconstant $kevent-read-filter -1 "Data available to read")
302 (defconstant $kevent-write-filter -2 "Writing is possible")
303 (defconstant $kevent-aio-filter -3 "AIO system call has been made")
304 (defconstant $kevent-vnode-filter -4 "Event occured on a file descriptor")
305 (defconstant $kevent-proc-filter -5 "Process performed one or more of the requested events")
306 (defconstant $kevent-signal-filter -6 "Attempted to deliver a signal to a process")
307 (defconstant $kevent-timer-filter -7 "Establishes an arbitrary timer")
308 (defconstant $kevent-netdev-filter -8 "Event occured on a network device")
309 (defconstant $kevent-filesystem-filter -9)
310
311 ) ; eval-when
312
313 ; FLAGS:
314
315 (defconstant $kevent-add #x01)
316 (defconstant $kevent-delete #x02)
317 (defconstant $kevent-enable #x04)
318 (defconstant $kevent-disable #x08)
319 (defconstant $kevent-oneshot #x10)
320 (defconstant $kevent-clear #x20)
321 (defconstant $kevent-error #x4000)
322 (defconstant $kevent-eof #x8000 "EV_EOF")
323
324 ;; FFLAGS:
325
326 (defconstant $kevent-file-delete #x01 "The file was unlinked from the file system")
327 (defconstant $kevent-file-write #x02 "A write occurred on the file")
328 (defconstant $kevent-file-extend #x04 "The file was extended")
329 (defconstant $kevent-file-attrib #x08 "The file had its attributes changed")
330 (defconstant $kevent-file-link #x10 "The link count on the file changed")
331 (defconstant $kevent-file-rename #x20 "The file was renamed")
332 (defconstant $kevent-file-revoke #x40 "Access to the file was revoked or the file system was unmounted")
333 (defconstant $kevent-file-all (logior $kevent-file-delete $kevent-file-write $kevent-file-extend
334 $kevent-file-attrib $kevent-file-link $kevent-file-rename $kevent-file-revoke))
335
336
337 (defconstant $kevent-net-linkup #x01 "Link is up")
338 (defconstant $kevent-net-linkdown #x02 "Link is down")
339 (defconstant $kevent-net-linkinvalid #x04 "Link state is invalid")
340 (defconstant $kevent-net-added #x08 "IP adress added")
341 (defconstant $kevent-net-deleted #x10 "IP adress deleted")
342
343 (define-condition kevent-error (simple-error)
344 ((errno :initform NIL :initarg :errno)
345 (ko :initform nil :type (or null kevent) :initarg :ko)
346 (syserr :initform (%system-errno)))
347 (:report
348 (lambda (c s)
349 (with-slots (errno ko syserr) c
350 (format s "kevent system call error ~A [~A]" errno syserr)
351 (when errno
352 (format s "(~A)" (%get-cstring (%system-strerror errno))))
353 (when ko
354 (format s " for ")
355 (let ((*standard-output* s))
356 (print-record ko *kevent-record*)))))))
357
358 (defun %kevent (kq &optional ke ko (timeout 0))
359 (check-type kq integer)
360 (rlet ((&timeout :timespec :sec timeout :usec 1))
361 (let ((num (with-timer ;; does not seem to make a difference...
362 (%system-kevent kq (or ke (%null-ptr))(if ke 1 0)(or ko (%null-ptr))(if ko 1 0) &timeout))))
363 ; "If an error occurs while processing an element of the changelist and there
364 ; is enough room in the eventlist, then the event will be placed in the eventlist with
365 ; EV_ERROR set in flags and the system error in data."
366 (when (and ko (plusp (logand $kevent-error (kevent-flags ko))))
367 (error 'kevent-error
368 :errno (kevent-data ko)
369 :ko ko))
370 ; "Otherwise, -1 will be returned, and errno will be set to indicate the error condition."
371 (when (= num -1)
372 ;; hack - opentransport provides the constants for the errors documented for the call
373 (case (%system-errno)
374 (0 (error "kevent system call failed with an unspecified error")) ;; should not happen!
375 (13 (error "The process does not have permission to register a filter"))
376 (14 (error "There was an error reading or writing the kevent structure")) ; EFAULT
377 (9 (error "The specified descriptor is invalid")) ; EBADF
378 (4 (error "A signal was delivered before the timeout expired and before any events were placed on the kqueue for return.")) ; EINTR
379 (22 (error "The specified time limit or filter is invalid")) ; EINVAL
380 (2 (error "The event could not be found to be modified or deleted")) ; ENOENT
381 (12 (error "No memory was available to register the event")) ; ENOMEM
382 (78 (error "The specified process to attach to does not exist"))) ; ESRCH
383 ;; shouldn't get here...
384 (errchk (%system-errno))
385 (error "error ~A" (%system-errno)))
386 (unless (zerop num)
387 (values ko num)))))
388
389 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
390 ;; CLOS INTERFACE
391
392 (defclass kqueue ()
393 ((kq :initform (system-kqueue)
394 :documentation "file descriptor referencing the kqueue")
395 (fds :initform NIL)) ;; ## better if kept on top level, perhaps as a hash table...
396 (:documentation "A kernal event notification channel"))
397
398 (defmethod initialize-instance :after ((q kqueue) &rest rest)
399 (declare (ignore rest))
400 (terminate-when-unreachable q 'kqueue-close))
401
402 (defmethod kqueue-close ((q kqueue))
403 (with-slots (kq fds) q
404 (when (or kq fds) ;; allow repeated close
405 (system-close kq)
406 (setf fds NIL)
407 (setf kq NIL))))
408
409 (defmethod kqueue-poll ((q kqueue))
410 "Polls a kqueue for kevents"
411 ;; may not have to be cleared, but just in case:
412 (flet ((kqueue-poll2 (ko)
413 (let ((result (with-slots (kq) q
414 (without-interrupts
415 (%kevent kq NIL ko)))))
416 (when result
417 (let ((type (kevent-filter result)))
418 (ecase type
419 (0 (values))
420 (#.$kevent-read-filter
421 (values
422 :read
423 (kevent-rref result :ident)
424 (kevent-rref result :flags)
425 (kevent-rref result :fflags)
426 (kevent-rref result :data)
427 (kevent-rref result :udata)))
428 (#.$kevent-write-filter :write)
429 (#.$kevent-aio-filter :aio)
430 (#.$kevent-vnode-filter
431 (values
432 :vnode
433 (cdr (assoc (kevent-rref result :ident) (slot-value q 'fds)))
434 (kevent-rref result :flags)
435 (kevent-rref result :fflags)
436 (kevent-rref result :data)
437 (kevent-rref result :udata)))
438 (#.$kevent-filesystem-filter :filesystem)))))))
439 (ecase *kevent-record*
440 (:kevent64
441 (rlet ((ko :kevent64 :ident 0 :filter 0 :flags 0 :fflags 0 :data 0 :udata (%null-ptr)))
442 (kqueue-poll2 ko)))
443 (:kevent32
444 (rlet ((ko :kevent32 :ident 0 :filter 0 :flags 0 :fflags 0 :data 0 :udata (%null-ptr)))
445 (kqueue-poll2 ko))))))
446
447 (defmethod kqueue-subscribe ((q kqueue) &key ident filter (flags 0) (fflags 0) (data 0) (udata (%null-ptr)))
448 (let ((ke (make-kevent :ident ident
449 :filter filter
450 :flags flags
451 :fflags fflags
452 :data data
453 :udata udata)))
454 (with-slots (kq) q
455 (without-interrupts
456 (%kevent kq ke)))))
457
458 (defmethod kqueue-vnode-subscribe ((q kqueue) pathname)
459 "Makes the queue report an event when there is a change to a directory or file"
460 (let* ((namestring (posix-namestring (full-pathname pathname)))
461 (fd (system-open namestring)))
462 (with-slots (fds) q
463 (push (cons fd pathname) fds))
464 (kqueue-subscribe q
465 :ident fd
466 :filter $kevent-vnode-filter
467 :flags (logior $kevent-add $kevent-clear)
468 :fflags $kevent-file-all)
469 namestring))
470
471 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
472
473 #+test
474 (defun kevent-d (pathname &optional (*standard-output* (fred)))
475 "Report changes to a file or directory"
476 (loop
477 with kqueue = (make-instance 'kqueue)
478 with sub = (kqueue-vnode-subscribe kqueue pathname)
479 for i from 1 to 60
480 for result = (multiple-value-list (kqueue-poll kqueue))
481 unless (equal result '(NIL))
482 do (progn
483 (format T "~A~%" result)
484 (force-output))
485 ; do (process-allow-schedule)
486 do (sleep 1)
487 finally (write-line "Done")
488 ))
489
490 #|
491
492 ; Report changes to this file in a fred window (save this document to see what happens):
493
494 (process-run-function "kevent-d" #'kevent-d *loading-file-source-file*
495 (fred))
496
497 ; Reports files added or removed from the directory of this file:
498
499 (process-run-function "kevent-d" #'kevent-d
500 (make-pathname :directory (pathname-directory *loading-file-source-file*))
501 (fred))
502 |#
503
504
505
506