Psst.. new poll here.
Psst.. new forums here.
Microsoft is blocking us again (TY IP Reputation!) so just use oauth login instead. :)
Paste
Pasted as Lisp by registered user Levenson ( 16 years ago )
;;; The MIT License
;;; Copyright (c) 2009-2010, MMER Foundation. All right reserved.
;;; Permission is hereby granted, free of charge, to any person obtaining a copy
;;; of this software and associated documentation files (the "Software"), to deal
;;; in the Software without restriction, including without limitation the rights
;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
;;; copies of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;; The above copyright notice and this permission notice shall be included in
;;; all copies or substantial portions of the Software.
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
;;; THE SOFTWARE.
;;; Unix notify module for event notification mechanism.
;;; This is only wrapper for keven/kqueue functions and it's mechanism.
;;; You can find more information at man kevent.
(defpackage :flan.module.kevent.notify
(:use :cl :cffi)
(:nicknames :kevent.notify)
;; (:export :kqueue-init
;; :event-set
;; :event-loop
;; :*evfilt-read*
;; :*evfilt-write*
;; :*evfilt-aio*
;; :*evfilt-vnode*
;; :*evfilt-proc*
;; :*evfilt-signal*
;; :*evfilt-timer*
;; :*evfilt-netdev*
;; :*evfilt-fs*
;; :*evfilt-lio*
;; :*evfilt-syscount*
;; :*ev-add*
;; :*ev-delete*
;; :*ev-enable*
;; :*ev-disable*
;; :*ev-oneshot*
;; :*ev-clear*
;; :*ev-sysflags*
;; :*ev-flag1*
;; :*ev-eof*
;; :*ev-error*
;; :*note-lowat*
;; :*note-delete*
;; :*note-write*
;; :*note-extend*
;; :*note-attrib*
;; :*note-link*
;; :*note-rename*
;; :*note-revoke*
;; :*note-exit*
;; :*note-fork*
;; :*note-exec*
;; :*note-pctrlmask*
;; :*note-pdatamask*
;; :*note-track*
;; :*note-trackerr*
;; :*note-child*
;; :*note-linkup*
;; :*note-linkdown*
;; :*note-linkinv*)
)
(in-package :flan.module.kevent.notify)
(defparameter *kevent-flags* (list
'(*ev-add* #x0001)
'(*ev-delete* #x0002)
'(*ev-enable* #x0004)
'(*ev-disable* #x0008)
'(*ev-oneshot* #x0010)
'(*ev-clear* #x0020)
'(*ev-sysflags* #xF000)
'(*ev-flag1* #x2000)
'(*ev-eof* #x8000)
'(*ev-error* #x4000)
))
(defparameter *kevent-filters* (list
'(*evfilt-read* -1)
'(*evfilt-write* -2)
'(*evfilt-aio* -3)
'(*evfilt-vnode* -4)
'(*evfilt-proc* -5)
'(*evfilt-signal* -6)
'(*evfilt-timer* -7)
'(*evfilt-netdev* -8)
'(*evfilt-fs* -9)
'(*evfilt-lio* -10)
'(*evfilt-syscount* 10)
))
(defparameter *kevent-note* (list
'(*note-lowat* #x0001)
'(*note-delete* #x0001)
'(*note-write* #x0002)
'(*note-extend* #x0004)
'(*note-attrib* #x0008)
'(*note-link* #x0010)
'(*note-rename* #x0020)
'(*note-revoke* #x0040)
'(*note-exit* #x80000000)
'(*note-fork* #x40000000)
'(*note-exec* #x20000000)
'(*note-pctrlmask* #xf0000000)
'(*note-pdatamask* #x000fffff)
'(*note-track* #x00000001)
'(*note-trackerr* #x00000002)
'(*note-child* #x00000004)
'(*note-linkup* #x0001)
'(*note-linkdown* #x0002)
'(*note-linkinv* #x0004)
))
(defvar *evfilt-read* -1)
(defvar *evfilt-write* -2)
(defvar *evfilt-aio* -3) ; attached to aio requests
(defvar *evfilt-vnode* -4) ; attached to vnodes
(defvar *evfilt-proc* -5) ; attached to struct proc
(defvar *evfilt-signal* -6) ; attached to struct proc
(defvar *evfilt-timer* -7) ; timers
(defvar *evfilt-netdev* -8) ; network devices
(defvar *evfilt-fs* -9) ; filesystem events
(defvar *evfilt-lio* -10) ; attached to lio requests
(defvar *evfilt-syscount* 10)
;; actions
(defvar *ev-add* #x0001) ;; add event to kq (implies enable)
(defvar *ev-delete* #x0002) ;; delete event from kq
(defvar *ev-enable* #x0004) ;; enable event
(defvar *ev-disable* #x0008) ;; disable event (not reported)
;; flags
(defvar *ev-oneshot* #x0010) ;; only report one occurrence
(defvar *ev-clear* #x0020) ;; clear event state after reporting
(defvar *ev-sysflags* #xF000) ;; reserved by system
(defvar *ev-flag1* #x2000) ;; filter-specific flag
;; returned values
(defvar *ev-eof* #x8000) ;; EOF detected
(defvar *ev-error* #x4000) ;; error, data contains errno
;; data/hint flags for EVFILT-{READ|WRITE}, shared with userspace
(defvar *note-lowat* #x0001) ;; low water mark
;; data/hint flags for EVFILT-VNODE, shared with userspace
(defvar *note-delete* #x0001) ;; vnode was removed
(defvar *note-write* #x0002) ;; data contents changed
(defvar *note-extend* #x0004) ;; size increased
(defvar *note-attrib* #x0008) ;; attributes changed
(defvar *note-link* #x0010) ;; link count changed
(defvar *note-rename* #x0020) ;; vnode was renamed
(defvar *note-revoke* #x0040) ;; vnode access was revoked
;; data/hint flags for EVFILT-PROC, shared with userspace
(defvar *note-exit* #x80000000) ;; process exited
(defvar *note-fork* #x40000000) ;; process forked
(defvar *note-exec* #x20000000) ;; process exec'd
(defvar *note-pctrlmask* #xf0000000) ;; mask for hint bits
(defvar *note-pdatamask* #x000fffff) ;; mask for pid
;; additional flags for EVFILT-PROC
(defvar *note-track* #x00000001) ;; follow across forks
(defvar *note-trackerr* #x00000002) ;; could not track child
(defvar *note-child* #x00000004) ;; am a child process
;; data/hint flags for EVFILT-NETDEV, shared with userspace
(defvar *note-linkup* #x0001) ;; link is up
(defvar *note-linkdown* #x0002) ;; link is down
(defvar *note-linkinv* #x0004) ;; link state is invalid
(define-foreign-library libc
(t (:default "libc")))
(use-foreign-library libc)
(defcvar "errno" :int)
(defcstruct c-kevent
"The kevent structure"
(ident (:pointer :uint))
(filter :short)
(flags :ushort)
(fflags :uint)
(data (:pointer :int))
(udata :pointer ))
(defcstruct c-timespec
(tv-sec (:int32))
(tv-nsec (:long)))
(defclass timespec ()
((tv-sec :initform 0
:initarg :sec
:accessor tv-sec) ; seconds
(tv-nsec :initform 0
:initarg :nsec
:accessor tv-nsec))) ; and nanoseconds
(defclass kevent ()
((ident :initform nil
:accessor kev-ident)
(filter :initform nil
:accessor kev-filter)
(flags :initform nil
:accessor kev-flags)
(fflags :initform nil
:accessor kev-fflags)
(data :initform nil
:accessor kev-data)
(udata :initform nil
:accessor kev-udata)))
;; (defparameter *KV* (make-instance 'c-kevent))
(defparameter *KQ* 0)
(defun kqueue ()
"The kqueue() system call creates a new kernel event queue and returns a descriptor."
(setf *KQ* (foreign-funcall "kqueue" :int)))
(defun c-strerror (errnum)
(foreign-funcall "strerror" :int errnum :string))
(defun c-kevent (kq changelist nchanges eventlist nevents timeout)
"The kevent() system call is used to register events with the queue,
and return any pending events to the user."
(foreign-funcall "kevent" :int kq :pointer changelist
:int nchanges :pointer eventlist :int nevents :pointer timeout :int))
(defun kevent-struct-p (item)
"Return True if item is kevent clos structure."
(equal (type-of item) 'kevent))
(defun timespec-p (item)
"Return True if item is timespec clos structure."
(equal (type-of item) 'timespec))
(defmethod translate-timespec ((timeout-object timespec) c-obj)
"Translate a clos timeout-object in to foreign c-obj timespec structure"
(with-foreign-slots ((tv-sec tv-nsec) c-obj c-timespec)
(setf tv-sec (tv-sec timeout-object)
tv-nsec (tv-nsec timeout-object))) c-obj)
(defmethod translate-kevent ((clos-object kevent) c-obj)
(with-foreign-slots ((ident filter flags fflags data udata) c-obj c-kevent)
;; (with-foreign-object (%time 'c-timespec)
(setf ident (make-pointer (kev-ident clos-object))
filter (kev-filter clos-object)
flags (kev-flags clos-object)
fflags (kev-fflags clos-object)
data (make-pointer (kev-data clos-object)))
(if (stringp (kev-udata clos-object))
(setf udata (foreign-string-alloc (kev-udata clos-object)))
(setf udata (make-pointer (kev-udata clos-object))))
;; (if (timespec-p (kev-data clos-object))
;; (progn
;; (translate-timepspec (kev-data clos-object) %time)
;; (setf data %time))))
))
(defmethod translate-to-kevent ((clos-object kevent) c-obj)
(with-foreign-slots ((ident filter flags fflags data udata) c-obj c-kevent)
(ev-set clos-object :ident (sb-sys:sap-int ident) :filter filter :flags flags :fflags fflags
:data (sb-sys:sap-int data)
:udata (foreign-string-to-lisp udata))))
(defmethod ev-set ((kv kevent)
&key; (udata 0) (data 0) (fflags 0) flags filter ident)
"The EV_SET() macro is provided for ease of initializing a kevent structure. "
(setf (kev-ident kv) ident
(kev-filter kv) filter
(kev-flags kv) flags
(kev-fflags kv) fflags
(kev-data kv) data
(kev-udata kv) udata))
(defmethod echo-kevent-structure ((kev kevent))
(format t "~{~& ID: ~d | FILTER: ~d | FLAGS: ~d | FFLAGS: ~d | DATA: ~d | UDATA: ~A ~}"
(list (kev-ident kev) (get-filter (kev-filter kev)) (get-flags (kev-flags kev))
(get-note (kev-fflags kev)) (kev-data kev) (kev-udata kev))))
(defun echo-c-structure (c-kev)
(with-foreign-slots ((ident filter flags fflags data udata) c-kev c-kevent)
(format t "~{~& ID: ~d | FILTER: ~d | FLAGS: ~d | FFLAGS: ~d | DATA: ~d | UDATA: ~A ~}"
(list ident (get-filter filter) (get-flags flags) fflags data udata))))
(let ((result (make-instance 'kevent)))
(defmethod kevent ((kev kevent) &optional; &key; (timeout nil timeout-p)
(changelist t))
"It will set up an event for into the kevent buffer."
(with-foreign-object (c-kev 'c-kevent)
(with-foreign-object (c-time 'c-timespec)
(when timeout-p
(translate-timepspec timeout c-time))
(translate-kevent kev c-kev)
(let ((n nil))
(if changelist
(setf n (c-kevent *KQ* c-kev 1 (null-pointer) 0 (if timeout-p c-time (null-pointer))))
(setf n (c-kevent *KQ* (null-pointer) 0 c-kev 1 (if timeout-p c-time (null-pointer)))))
(if (minusp n)
(progn
(warn "Code ~d ~s" *errno* (princ-to-string (c-strerror *errno*))) n)
(progn
(translate-to-kevent result c-kev) result)))))))
(defun get-filter (value)
(loop as x in *kevent-filters*
when (equal value (second x)) do
(return (first x))))
(defun get-flags (value)
(loop as x in *kevent-flags*
when (logtest value (second x))
collect (first x)))
(defun get-note (value)
(loop as x in *kevent-note*
when (logtest value (second x))
collect (first x)))
(defun test (filepath &optional; &key; (proc-id 0) )
;; (setf *KQ* (kqueue))
(if (zerop *KQ*)
(kqueue))
(let ((kev (make-instance 'kevent))
(time-t (make-instance 'timespec :sec 10)))
(with-open-file (fstream filepath :direction :input)
(let ((fd (sb-sys:fd-stream-fd fstream)))
(file-position fstream (file-length fstream))
;; *EVFILT-READ*
(ev-set kev :ident fd :filter *evfilt-read* :flags *ev-add* :udata filepath)
(when (kevent-struct-p (kevent kev :changelist t))
(warn "Filter: ~s set for ~s." (get-filter (kev-filter kev)) filepath))
;; *EVFILT-VNODE*
(ev-set kev :ident fd :filter *evfilt-vnode* :flags *ev-add*
:fflags (logior *note-delete* *note-rename*) :udata filepath)
(when (kevent-struct-p (kevent kev :changelist t))
(warn "Filter: ~s with Event(s): ~s set for ~s." (get-filter (kev-filter kev)) (get-note (kev-fflags kev)) filepath))
;; *EVFILT-TIMER**
(ev-set kev :ident fd :filter *evfilt-timer* :flags *ev-add* :data 2000 :udata filepath)
(when (kevent-struct-p (kevent kev :changelist t))
(warn "Filter: ~s set for ~s." (get-filter (kev-filter kev)) filepath))
;; *EVFILT-PROC*
(when (plusp proc-id)
(ev-set kev :ident proc-id :filter *evfilt-proc* :flags *ev-add* :fflags (logior *note-fork* *note-track* *note-exec*))
(when (kevent-struct-p (kevent kev :changelist t))
(warn "Filter: ~s set for ~s." (get-filter (kev-filter kev)) filepath)))
(loop with n = 0 and timeout = 0 do
(setf n (kevent kev :changelist nil))
when (kevent-struct-p n) do
(echo-kevent-structure n)
(format t "Timeout ~d" timeout)
(when (equal (kev-filter n) *evfilt-timer*)
(format t "~&==> Timer ")
(incf timeout)
(when (>= timeout 10)
(return timeout)))
(when (equal (kev-filter n) *evfilt-read*)
(format t "~&==> Read" )
(setf timeout 0)
;; (format t "~& Need to read: ~d " (data n))
(handler-case
(do ((line (read-line fstream nil)
(read-line fstream nil)))
((null line) t)
(format t "~& ~3t ~s" line))
(stream-decoding-error (c)
(warn (princ-to-string c)))))
(when (equal (kev-filter n) *evfilt-proc*)
(format t "~&==> Proc")
(setf timeout 0))
)))))
Revise this Paste