[usocket-cvs] r512 - in usocket/trunk: backend vendor
Chun Tian (binghe)
ctian at common-lisp.net
Mon Jan 4 10:22:53 UTC 2010
Author: ctian
Date: Mon Jan 4 05:22:52 2010
New Revision: 512
Log:
Include MCL Issue 29, and slightly change kqueue.lisp to make it compiles on MCL.
Modified:
usocket/trunk/backend/mcl.lisp
usocket/trunk/vendor/kqueue.lisp
Modified: usocket/trunk/backend/mcl.lisp
==============================================================================
--- usocket/trunk/backend/mcl.lisp (original)
+++ usocket/trunk/backend/mcl.lisp Mon Jan 4 05:22:52 2010
@@ -1,11 +1,43 @@
;; MCL backend for USOCKET 0.4.1
;; Terje Norderhaug <terje at in-progress.com>, January 1, 2009
-(in-package :usocket)
+(in-package :ccl)
(eval-when (:compile-toplevel :load-toplevel :execute)
(require :opentransport))
+;; MCL Issue 29: Passive TCP connections on OS assigned ports
+;; see http://code.google.com/p/mcl/issues/detail?id=29 for details
+(ccl:advise ot-conn-tcp-passive-connect
+ (destructuring-bind (conn port &optional (allow-reuse t)) arglist
+ (declare (ignore allow-reuse))
+ (if (eql port #$kOTAnyInetAddress)
+ ;; Avoids registering a proxy for port 0 but instead registers one for the true port:
+ (multiple-value-bind (proxy result)
+ (let* ((*opentransport-class-proxies* NIL) ; makes ot-find-proxy return NIL
+ (result (:do-it)) ;; pushes onto *opentransport-class-proxies*
+ (proxy (prog1
+ (pop *opentransport-class-proxies*)
+ (assert (not *opentransport-class-proxies*))))
+ (context (cdr proxy))
+ (tmpconn (make-ot-conn :context context
+ :endpoint (pref context :ot-context.ref)))
+ (localaddress (ot-conn-tcp-get-addresses tmpconn)))
+ (declare (dynamic-extent tmpconn))
+ ;; replace original set in body of function
+ (setf (ot-conn-local-address conn) localaddress)
+ (values
+ (cons localaddress context)
+ result))
+ ;; need to be outside local binding of *opentransport-class-proxies*
+ (without-interrupts
+ (push proxy *opentransport-class-proxies*))
+ result)
+ (:do-it)))
+ :when :around :name 'ot-conn-tcp-passive-connect-any-address)
+
+(in-package :usocket)
+
(defun handle-condition (condition &optional socket)
; incomplete, needs to handle additional conditions
(flet ((raise-error (&optional socket-condition)
Modified: usocket/trunk/vendor/kqueue.lisp
==============================================================================
--- usocket/trunk/vendor/kqueue.lisp (original)
+++ usocket/trunk/vendor/kqueue.lisp Mon Jan 4 05:22:52 2010
@@ -1 +1 @@
-;;;-*-Mode: LISP; Package: CCL -*-
;;
;; KQUEUE.LISP
;;
;; KQUEUE - BSD kernel event notification mechanism support for Common LISP.
;; Copyright (C) 2007 Terje Norderhaug <terje at in-progress.com>
;; Released under LGPL - see <http://www.gnu.org>.
;; Alternative licensing available upon request.
;;
;; DISCLAIMER: The user of this module should understand that executing code is a potentially hazardous
;; activity, and that many dangers and obstacles, marked or unmarked, may exist within this code.
;; As a condition of your use of the module, you assume all risk of personal injury, death, or property
;; loss, and all other bad things that may happen, even if caused by negligence, ignorance or stupidity.
;; The author is is no way responsible, and besides, does not have "deep pockets" nor any spare change.
;;
;; Version: 0.20 alpha (July 26, 2009) - subject to major revisions, so consider yourself warned.
;; Tested with Macintosh Common LISP 5.1 and 5.2, but is intended to be platform and system independent in the future.
;;
;; Email feedback and improvements to <terje at in-progress.com>.
;; Updated versions will be available from <http://www.in-progress.com/src/>.
;;
;; RELATED IMPLEMENTATIONS
;; There is another kevent.lisp for other platforms by Risto Laakso (merge?).
;; Also a Scheme kevent.ss by Jose Antonio Ortega.
;;
;; SEE ALSO:
;; http://people.freebsd.org/~jlemon/papers/kqueue.pdf
;; http://developer.apple.com/samplecode/FileNotification/index.html
;; The Man page for kqueue() or kevent().
;; PyKQueue - Python OO interface to KQueue.
;; LibEvent - an event notification library in C by Niels Provos.
;; Liboop - another abstract library in C on top of kevent or other kernel notification.
#| HISTORY:
2007-Oct-18 terje version 0.1 released on the Info-MCL mailing list.
2008-Aug-21 terje load-framework-bundle is not needed under MCL 5.2
2008-Aug-21 terje rename get-addr to lookup-function-in-bundle (only for pre MCL 5.2)
2009-Jul-19 terje uses kevent-error condition and strerror.
2009-Jul-24 terje reports errors unless nil-if-not-found in lookup-function-in-bundle.
2009-Jul-24 terje kevent :variant for C's intptr_t type for 64bit (and osx 10.5) compatibility.
2009-Jul-25 terje 64bit support, dynamically determined for PPC. Kudos to Glen Foy for helping out.
2009-Jul-25 terje make-kevent function.
|#
#| IMPLEMENTATION NOTES:
kevents are copied into and from the kernel, so the records don't have to be kept in the app!
kevents does not work in OSX before 10.3.
*kevent-record* has to be explcitly set to :kevent64 to work on 64bit intel macs.
Consider using sysctlbyname() to test for 64bit,
combining hw.cpu64bit_capable, hw.optional.x86_64 and hw.optional.64bitops
|#
(in-package :ccl)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#-ccl-5.2 ; has been added to MCL 5.2
(defmethod load-framework-bundle ((framework-name string) &key (load-executable t))
;; FRAMWORK CALL FUNCTIONALITY FROM BSD.LISP
;; (C) 2003 Brendan Burns <bburns at cs.umass.edu>
;; Released under LGPL.
(with-cfstrs ((framework framework-name))
(let ((err 0)
(baseURL nil)
(bundleURL nil)
(result nil))
(rlet ((folder :fsref))
;; Find the folder holding the bundle
(setf err (#_FSFindFolder #$kOnAppropriateDisk #$kFrameworksFolderType
t folder))
;; if everything's cool, make a URL for it
(when (zerop err)
(setf baseURL (#_CFURLCreateFromFSRef (%null-ptr) folder))
(if (%null-ptr-p baseURL)
(setf err #$coreFoundationUnknownErr)))
;; if everything's cool, make a URL for the bundle
(when (zerop err)
(setf bundleURL (#_CFURLCreateCopyAppendingPathComponent (%null-ptr)
baseURL framework nil))
(if (%null-ptr-p bundleURL)
(setf err #$coreFoundationUnknownErr)))
;; if everything's cool, load it
(when (zerop err)
(setf result (#_CFBundleCreate (%null-ptr) bundleURL))
(if (%null-ptr-p result)
(setf err #$coreFoundationUnknownErr)))
;; if everything's cool, and the user wants it loaded, load it
(when (and load-executable (zerop err))
(if (not (#_CFBundleLoadExecutable result))
(setf err #$coreFoundationUnknownErr)))
;; if there's an error, but we've got a pointer, free it and clear result
(when (and (not (zerop err)) (not (%null-ptr-p result)))
(#_CFRelease result)
(setf result nil))
;; free the URLs if there non-null
(when (not (%null-ptr-p bundleURL))
(#_CFRelease bundleURL))
(when (not (%null-ptr-p baseURL))
(#_CFRelease baseURL))
;; return pointer + error value
(values result err)))))
#+ignore
(defun get-addr (bundle name)
(let* ((addr (#_CFBundleGetFunctionPointerForName bundle name)))
(rlet ((buf :long))
(setf (%get-ptr buf) addr)
(ash (%get-signed-long buf) -2))))
#-ccl-5.2
(defun lookup-function-in-bundle (name bundle &optional nil-if-not-found)
(with-cfstrs ((str name))
(let* ((addr (#_CFBundleGetFunctionPointerForName bundle str)))
(if (%null-ptr-p addr)
(unless nil-if-not-found
(error "Couldn't resolve address of foreign function ~s" name))
(rlet ((buf :long)) ;; mcl 5.2 uses %fixnum-from-macptr here
(setf (%get-ptr buf) addr)
(ash (%get-signed-long buf) -2))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Convenient way to declare BSD system calls
#+ignore
(defparameter *system-bundle*
#+ccl-5.2 (get-bundle-for-framework-name "System.framework")
#-ccl-5.2
(let ((bundle (load-framework-bundle "System.framework")))
(terminate-when-unreachable bundle (lambda (b)(#_CFRelease b)))
bundle))
(defmacro declare-bundle-ff (name name-string &rest arglist &aux (fn (gensym (format nil "ff_~A_" (string name)))))
;; Is there an existing define-trap like macro for this? or could one be modified for use with bundles?
`(progn
(defloadvar ,fn
(let* ((bundle #+ccl-5.2 (get-bundle-for-framework-name "System.framework")
#-ccl-5.2
(let ((bundle (load-framework-bundle "System.framework")))
(terminate-when-unreachable bundle (lambda (b)(#_CFRelease b)))
bundle)))
(lookup-function-in-bundle ,name-string bundle)))
,(let ((args (do ((arglist arglist (cddr arglist))
(result))
((not (cdr arglist)) (nreverse result))
(push (second arglist) result))))
`(defun ,name ,args
(ppc-ff-call ,fn , at arglist)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(declare-bundle-ff %system-kqueue "kqueue"
:signed-fullword) ;; returns a file descriptor no!
(defun system-kqueue ()
(let ((kq (%system-kqueue)))
(if (= kq -1)
(ecase (%system-errno)
(12 (error "The kernel failed to allocate enough memory for the kernel queue")) ; ENOMEM
(24 (error "The per-process descriptor table is full")) ; EMFILE
(23 (error "The system file table is full"))) ; ENFILE
kq)))
(declare-bundle-ff %system-kevent "kevent"
:unsigned-fullword kq
:address ke
:unsigned-fullword nke
:address ko
:unsigned-fullword nko
:address timeout
:signed-fullword)
(declare-bundle-ff %system-open "open"
:address name
:unsigned-fullword mode
:unsigned-fullword arg
:signed-fullword)
(declare-bundle-ff %system-close "close"
:unsigned-fullword fd
:signed-fullword)
(declare-bundle-ff %system-errno* "__error"
:signed-fullword)
(declare-bundle-ff %system-strerror "strerror"
:signed-fullword errno
:address)
(defun %system-errno ()
(%get-fixnum (%int-to-ptr (%system-errno*))))
; (%system-errno)
(defconstant $O-EVTONLY #x8000)
; (defconstant $O-NONBLOCK #x800 "Non blocking mode")
(defun system-open (posix-namestring)
"Low level open function, as in C, returns an fd number"
(with-cstrs ((name posix-namestring))
(%system-open name $O-EVTONLY 0)))
(defun system-close (fd)
(%system-close fd))
(defrecord timespec
(sec :unsigned-long)
(usec :unsigned-long))
(defVar *kevent-record* nil)
(def-ccl-pointers determine-64bit-kevents ()
(setf *kevent-record*
(if (ccl::gestalt #$gestaltPowerPCProcessorFeatures
#+ccl-5.2 #$gestaltPowerPCHas64BitSupport #-ccl-5.2 6)
:kevent32
:kevent64)))
(defrecord :kevent32
(ident :unsigned-long) ; uintptr_t
(filter :short)
(flags :unsigned-short)
(fflags :unsigned-long)
(data :long) ; intptr_t
(udata :pointer))
(defrecord :kevent64
(:variant ; uintptr_t
((ident64 :uint64))
((ident :unsigned-long)))
(filter :short)
(flags :unsigned-short)
(fflags :unsigned-long)
(:variant ; intptr_t
((data64 :sint64))
((data :long)))
(:variant ; RMCL :pointer is 32bit
((udata64 :uint64))
((udata :pointer))))
(defun make-kevent (&key (ident 0) (filter 0) (flags 0) (fflags 0) (data 0) (udata *null-ptr*))
(ecase *kevent-record*
(:kevent64
(make-record kevent64
:ident ident
:filter filter
:flags flags
:fflags fflags
:data data
:udata udata))
(:kevent32
(make-record kevent32
:ident ident
:filter filter
:flags flags
:fflags fflags
:data data
:udata udata))))
(defun kevent-rref (ke field)
(ecase *kevent-record*
(:kevent32
(ecase field
(:ident (rref ke :kevent32.ident))
(:filter (rref ke :kevent32.filter))
(:flags (rref ke :kevent32.flags))
(:fflags (rref ke :kevent32.fflags))
(:data (rref ke :kevent32.data))
(:udata (rref ke :kevent32.udata))))
(:kevent64
(ecase field
(:ident (rref ke :kevent64.ident))
(:filter (rref ke :kevent64.filter))
(:flags (rref ke :kevent64.flags))
(:fflags (rref ke :kevent64.fflags))
(:data (rref ke :kevent64.data))
(:udata (rref ke :kevent64.udata))))))
(defun kevent-filter (ke)
(kevent-rref ke :filter))
(defun kevent-flags (ke)
(kevent-rref ke :flags))
(defun kevent-data (ke)
(kevent-rref ke :data))
;; FILTER TYPES:
(defconstant $kevent-read-filter -1 "Data available to read")
(defconstant $kevent-write-filter -2 "Writing is possible")
(defconstant $kevent-aio-filter -3 "AIO system call has been made")
(defconstant $kevent-vnode-filter -4 "Event occured on a file descriptor")
(defconstant $kevent-proc-filter -5 "Process performed one or more of the requested events")
(defconstant $kevent-signal-filter -6 "Attempted to deliver a signal to a process")
(defconstant $kevent-timer-filter -7 "Establishes an arbitrary timer")
(defconstant $kevent-netdev-filter -8 "Event occured on a network device")
(defconstant $kevent-filesystem-filter -9)
; FLAGS:
(defconstant $kevent-add #x01)
(defconstant $kevent-delete #x02)
(defconstant $kevent-enable #x04)
(defconstant $kevent-disable #x08)
(defconstant $kevent-oneshot #x10)
(defconstant $kevent-clear #x20)
(defconstant $kevent-error #x4000)
(defconstant $kevent-eof #x8000 "EV_EOF")
;; FFLAGS:
(defconstant $kevent-file-delete #x01 "The file was unlinked from the file system")
(defconstant $kevent-file-write #x02 "A write occurred on the file")
(defconstant $kevent-file-extend #x04 "The file was extended")
(defconstant $kevent-file-attrib #x08 "The file had its attributes changed")
(defconstant $kevent-file-link #x10 "The link count on the file changed")
(defconstant $kevent-file-rename #x20 "The file was renamed")
(defconstant $kevent-file-revoke #x40 "Access to the file was revoked or the file system was unmounted")
(defconstant $kevent-file-all (logior $kevent-file-delete $kevent-file-write $kevent-file-extend
$kevent-file-attrib $kevent-file-link $kevent-file-rename $kevent-file-revoke))
(defconstant $kevent-net-linkup #x01 "Link is up")
(defconstant $kevent-net-linkdown #x02 "Link is down")
(defconstant $kevent-net-linkinvalid #x04 "Link state is invalid")
(defconstant $kevent-net-added #x08 "IP adress added")
(defconstant $kevent-net-deleted #x10 "IP adress deleted")
(define-condition kevent-error (simple-error)
((errno :initform NIL :initarg :errno)
(ko :initform nil :type (or null kevent) :initarg :ko)
(syserr :initform (%system-errno)))
(:report
(lambda (c s)
(with-slots (errno ko syserr) c
(format s "kevent system call error ~A [~A]" errno syserr)
(when errno
(format s "(~A)" (%get-cstring (%system-strerror errno))))
(when ko
(format s " for ")
(let ((*standard-output* s))
(print-record ko *kevent-record*)))))))
(defun %kevent (kq &optional ke ko (timeout 0))
(check-type kq integer)
(rlet ((&timeout :timespec :sec timeout :usec 1))
(let ((num (with-timer ;; does not seem to make a difference...
(%system-kevent kq (or ke (%null-ptr))(if ke 1 0)(or ko (%null-ptr))(if ko 1 0) &timeout))))
; "If an error occurs while processing an element of the changelist and there
; is enough room in the eventlist, then the event will be placed in the eventlist with
; EV_ERROR set in flags and the system error in data."
(when (and ko (plusp (logand $kevent-error (kevent-flags ko))))
(error 'kevent-error
:errno (kevent-data ko)
:ko ko))
; "Otherwise, -1 will be returned, and errno will be set to indicate the error condition."
(when (= num -1)
;; hack - opentransport provides the constants for the errors documented for the call
(case (%system-errno)
(0 (error "kevent system call failed with an unspecified error")) ;; should not happen!
(13 (error "The process does not have permission to register a filter"))
(14 (error "There was an error reading or writing the kevent structure")) ; EFAULT
(9 (error "The specified descriptor is invalid")) ; EBADF
(4 (error "A signal was delivered before the timeout expired and before any events were placed on the kqueue for return.")) ; EINTR
(22 (error "The specified time limit or filter is invalid")) ; EINVAL
(2 (error "The event could not be found to be modified or deleted")) ; ENOENT
(12 (error "No memory was available to register the event")) ; ENOMEM
(78 (error "The specified process to attach to does not exist"))) ; ESRCH
;; shouldn't get here...
(errchk (%system-errno))
(error "error ~A" (%system-errno)))
(unless (zerop num)
(values ko num)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; CLOS INTERFACE
(defclass kqueue ()
((kq :initform (system-kqueue)
:documentation "file descriptor referencing the kqueue")
(fds :initform NIL)) ;; ## better if kept on top level, perhaps as a hash table...
(:documentation "A kernal event notification channel"))
(defmethod initialize-instance :after ((q kqueue) &rest rest)
(declare (ignore rest))
(terminate-when-unreachable q 'kqueue-close))
(defmethod kqueue-close ((q kqueue))
(with-slots (kq fds) q
(when (or kq fds) ;; allow repeated close
(system-close kq)
(setf fds NIL)
(setf kq NIL))))
(defmethod kqueue-poll ((q kqueue))
"Polls a kqueue for kevents"
;; may not have to be cleared, but just in case:
(flet ((kqueue-poll2 (ko)
(let ((result (with-slots (kq) q
(without-interrupts
(%kevent kq NIL ko)))))
(when result
(let ((type (kevent-filter result)))
(ecase type
(0 (values))
(#.$kevent-read-filter
(values
:read
(kevent-rref result :ident)
(kevent-rref result :flags)
(kevent-rref result :fflags)
(kevent-rref result :data)
(kevent-rref result :udata)))
(#.$kevent-write-filter :write)
(#.$kevent-aio-filter :aio)
(#.$kevent-vnode-filter
(values
:vnode
(cdr (assoc (kevent-rref result :ident) (slot-value q 'fds)))
(kevent-rref result :flags)
(kevent-rref result :fflags)
(kevent-rref result :data)
(kevent-rref result :udata)))
(#.$kevent-filesystem-filter :filesystem)))))))
(ecase *kevent-record*
(:kevent64
(rlet ((ko :kevent64 :ident 0 :filter 0 :flags 0 :fflags 0 :data 0 :udata (%null-ptr)))
(kqueue-poll2 ko)))
(:kevent32
(rlet ((ko :kevent32 :ident 0 :filter 0 :flags 0 :fflags 0 :data 0 :udata (%null-ptr)))
(kqueue-poll2 ko))))))
(defmethod kqueue-subscribe ((q kqueue) &key ident filter (flags 0) (fflags 0) (data 0) (udata (%null-ptr)))
(let ((ke (make-kevent :ident ident
:filter filter
:flags flags
:fflags fflags
:data data
:udata udata)))
(with-slots (kq) q
(without-interrupts
(%kevent kq ke)))))
(defmethod kqueue-vnode-subscribe ((q kqueue) pathname)
"Makes the queue report an event when there is a change to a directory or file"
(let* ((namestring (posix-namestring (full-pathname pathname)))
(fd (system-open namestring)))
(with-slots (fds) q
(push (cons fd pathname) fds))
(kqueue-subscribe q
:ident fd
:filter $kevent-vnode-filter
:flags (logior $kevent-add $kevent-clear)
:fflags $kevent-file-all)
namestring))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#+test
(defun kevent-d (pathname &optional (*standard-output* (fred)))
"Report changes to a file or directory"
(loop
with kqueue = (make-instance 'kqueue)
with sub = (kqueue-vnode-subscribe kqueue pathname)
for i from 1 to 60
for result = (multiple-value-list (kqueue-poll kqueue))
unless (equal result '(NIL))
do (progn
(format T "~A~%" result)
(force-output))
; do (process-allow-schedule)
do (sleep 1)
finally (write-line "Done")
))
#|
; Report changes to this file in a fred window (save this document to see what happens):
(process-run-function "kevent-d" #'kevent-d *loading-file-source-file*
(fred))
; Reports files added or removed from the directory of this file:
(process-run-function "kevent-d" #'kevent-d
(make-pathname :directory (pathname-directory *loading-file-source-file*))
(fred))
|#
\ No newline at end of file
+;;;-*-Mode: LISP; Package: CCL -*-
;;
;; KQUEUE.LISP
;;
;; KQUEUE - BSD kernel event notification mechanism support for Common LISP.
;; Copyright (C) 2007 Terje Norderhaug <terje at in-progress.com>
;; Released under LGPL - see <http://www.gnu.org>.
;; Alternative licensing available upon request.
;;
;; DISCLAIMER: The user of this module should understand that executing code is a potentially hazardous
;; activity, and that many dangers and obstacles, marked or unmarked, may exist within this code.
;; As a condition of your use of the module, you assume all risk of personal injury, death, or property
;; loss, and all other bad things that may happen, even if caused by negligence, ignorance or stupidity.
;; The author is is no way responsible, and besides, does not have "deep pockets" nor any spare change.
;;
;; Version: 0.20 alpha (July 26, 2009) - subject to major revisions, so consider yourself warned.
;; Tested with Macintosh Common LISP 5.1 and 5.2, but is intended to be platform and system independent in the future.
;;
;; Email feedback and improvements to <terje at in-progress.com>.
;; Updated versions will be available from <http://www.in-progress.com/src/>.
;;
;; RELATED IMPLEMENTATIONS
;; There is another kevent.lisp for other platforms by Risto Laakso (merge?).
;; Also a Scheme kevent.ss by Jose Antonio Ortega.
;;
;; SEE ALSO:
;; http://people.freebsd.org/~jlemon/papers/kqueue.pdf
;; http://developer.apple.com/samplecode/FileNotification/index.html
;; The Man page for kqueue() or kevent().
;; PyKQueue - Python OO interface to KQueue.
;; LibEvent - an event notification library in C by Niels Provos.
;; Liboop - another abstract library in C on top of kevent or other kernel notification.
#| HISTORY:
2007-Oct-18 terje version 0.1 released on the Info-MCL mailing list.
2008-Aug-21 terje load-framework-bundle is not needed under MCL 5.2
2008-Aug-21 terje rename get-addr to lookup-function-in-bundle (only for pre MCL 5.2)
2009-Jul-19 terje uses kevent-error condition and strerror.
2009-Jul-24 terje reports errors unless nil-if-not-found in lookup-function-in-bundle.
2009-Jul-24 terje kevent :variant for C's intptr_t type for 64bit (and osx 10.5) compatibility.
2009-Jul-25 terje 64bit support, dynamically determined for PPC. Kudos to Glen Foy for helping out.
2009-Jul-25 terje make-kevent function.
|#
#| IMPLEMENTATION NOTES:
kevents are copied into and from the kernel, so the records don't have to be kept in the app!
kevents does not work in OSX before 10.3.
*kevent-record* has to be explcitly set to :kevent64 to work on 64bit intel macs.
Consider using sysctlbyname() to test for 64bit,
combining hw.cpu64bit_capable, hw.optional.x86_64 and hw.optional.64bitops
|#
(in-package :ccl)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#-ccl-5.2 ; has been added to MCL 5.2
(defmethod load-framework-bundle ((framework-name string) &key (load-executable t))
;; FRAMWORK CALL FUNCTIONALITY FROM BSD.LISP
;; (C) 2003 Brendan Burns <bburns at cs.umass.edu>
;; Released under LGPL.
(with-cfstrs ((framework framework-name))
(let ((err 0)
(baseURL nil)
(bundleURL nil)
(result nil))
(rlet ((folder :fsref))
;; Find the folder holding the bundle
(setf err (#_FSFindFolder #$kOnAppropriateDisk #$kFrameworksFolderType
t folder))
;; if everything's cool, make a URL for it
(when (zerop err)
(setf baseURL (#_CFURLCreateFromFSRef (%null-ptr) folder))
(if (%null-ptr-p baseURL)
(setf err #$coreFoundationUnknownErr)))
;; if everything's cool, make a URL for the bundle
(when (zerop err)
(setf bundleURL (#_CFURLCreateCopyAppendingPathComponent (%null-ptr)
baseURL framework nil))
(if (%null-ptr-p bundleURL)
(setf err #$coreFoundationUnknownErr)))
;; if everything's cool, load it
(when (zerop err)
(setf result (#_CFBundleCreate (%null-ptr) bundleURL))
(if (%null-ptr-p result)
(setf err #$coreFoundationUnknownErr)))
;; if everything's cool, and the user wants it loaded, load it
(when (and load-executable (zerop err))
(if (not (#_CFBundleLoadExecutable result))
(setf err #$coreFoundationUnknownErr)))
;; if there's an error, but we've got a pointer, free it and clear result
(when (and (not (zerop err)) (not (%null-ptr-p result)))
(#_CFRelease result)
(setf result nil))
;; free the URLs if there non-null
(when (not (%null-ptr-p bundleURL))
(#_CFRelease bundleURL))
(when (not (%null-ptr-p baseURL))
(#_CFRelease baseURL))
;; return pointer + error value
(values result err)))))
#+ignore
(defun get-addr (bundle name)
(let* ((addr (#_CFBundleGetFunctionPointerForName bundle name)))
(rlet ((buf :long))
(setf (%get-ptr buf) addr)
(ash (%get-signed-long buf) -2))))
#-ccl-5.2
(defun lookup-function-in-bundle (name bundle &optional nil-if-not-found)
(with-cfstrs ((str name))
(let* ((addr (#_CFBundleGetFunctionPointerForName bundle str)))
(if (%null-ptr-p addr)
(unless nil-if-not-found
(error "Couldn't resolve address of foreign function ~s" name))
(rlet ((buf :long)) ;; mcl 5.2 uses %fixnum-from-macptr here
(setf (%get-ptr buf) addr)
(ash (%get-signed-long buf) -2))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Convenient way to declare BSD system calls
#+ignore
(defparameter *system-bundle*
#+ccl-5.2 (get-bundle-for-framework-name "System.framework")
#-ccl-5.2
(let ((bundle (load-framework-bundle "System.framework")))
(terminate-when-unreachable bundle (lambda (b)(#_CFRelease b)))
bundle))
(defmacro declare-bundle-ff (name name-string &rest arglist &aux (fn (gensym (format nil "ff_~A_" (string name)))))
;; Is there an existing define-trap like macro for this? or could one be modified for use with bundles?
`(progn
(defloadvar ,fn
(let* ((bundle #+ccl-5.2 (get-bundle-for-framework-name "System.framework")
#-ccl-5.2
(let ((bundle (load-framework-bundle "System.framework")))
(terminate-when-unreachable bundle (lambda (b)(#_CFRelease b)))
bundle)))
(lookup-function-in-bundle ,name-string bundle)))
,(let ((args (do ((arglist arglist (cddr arglist))
(result))
((not (cdr arglist)) (nreverse result))
(push (second arglist) result))))
`(defun ,name ,args
(ppc-ff-call ,fn , at arglist)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(declare-bundle-ff %system-kqueue "kqueue"
:signed-fullword) ;; returns a file descriptor no!
(defun system-kqueue ()
(let ((kq (%system-kqueue)))
(if (= kq -1)
(ecase (%system-errno)
(12 (error "The kernel failed to allocate enough memory for the kernel queue")) ; ENOMEM
(24 (error "The per-process descriptor table is full")) ; EMFILE
(23 (error "The system file table is full"))) ; ENFILE
kq)))
(declare-bundle-ff %system-kevent "kevent"
:unsigned-fullword kq
:address ke
:unsigned-fullword nke
:address ko
:unsigned-fullword nko
:address timeout
:signed-fullword)
(declare-bundle-ff %system-open "open"
:address name
:unsigned-fullword mode
:unsigned-fullword arg
:signed-fullword)
(declare-bundle-ff %system-close "close"
:unsigned-fullword fd
:signed-fullword)
(declare-bundle-ff %system-errno* "__error"
:signed-fullword)
(declare-bundle-ff %system-strerror "strerror"
:signed-fullword errno
:address)
(defun %system-errno ()
(%get-fixnum (%int-to-ptr (%system-errno*))))
; (%system-errno)
(defconstant $O-EVTONLY #x8000)
; (defconstant $O-NONBLOCK #x800 "Non blocking mode")
(defun system-open (posix-namestring)
"Low level open function, as in C, returns an fd number"
(with-cstrs ((name posix-namestring))
(%system-open name $O-EVTONLY 0)))
(defun system-close (fd)
(%system-close fd))
(defrecord timespec
(sec :unsigned-long)
(usec :unsigned-long))
(defVar *kevent-record* nil)
(def-ccl-pointers determine-64bit-kevents ()
(setf *kevent-record*
(if (ccl::gestalt #$gestaltPowerPCProcessorFeatures
#+ccl-5.2 #$gestaltPowerPCHas64BitSupport #-ccl-5.2 6)
:kevent32
:kevent64)))
(defrecord :kevent32
(ident :unsigned-long) ; uintptr_t
(filter :short)
(flags :unsigned-short)
(fflags :unsigned-long)
(data :long) ; intptr_t
(udata :pointer))
(defrecord :kevent64
(:variant ; uintptr_t
((ident64 :uint64))
((ident :unsigned-long)))
(filter :short)
(flags :unsigned-short)
(fflags :unsigned-long)
(:variant ; intptr_t
((data64 :sint64))
((data :long)))
(:variant ; RMCL :pointer is 32bit
((udata64 :uint64))
((udata :pointer))))
(defun make-kevent (&key (ident 0) (filter 0) (flags 0) (fflags 0) (data 0) (udata *null-ptr*))
(ecase *kevent-record*
(:kevent64
(make-record kevent64
:ident ident
:filter filter
:flags flags
:fflags fflags
:data data
:udata udata))
(:kevent32
(make-record kevent32
:ident ident
:filter filter
:flags flags
:fflags fflags
:data data
:udata udata))))
(defun kevent-rref (ke field)
(ecase *kevent-record*
(:kevent32
(ecase field
(:ident (rref ke :kevent32.ident))
(:filter (rref ke :kevent32.filter))
(:flags (rref ke :kevent32.flags))
(:fflags (rref ke :kevent32.fflags))
(:data (rref ke :kevent32.data))
(:udata (rref ke :kevent32.udata))))
(:kevent64
(ecase field
(:ident (rref ke :kevent64.ident))
(:filter (rref ke :kevent64.filter))
(:flags (rref ke :kevent64.flags))
(:fflags (rref ke :kevent64.fflags))
(:data (rref ke :kevent64.data))
(:udata (rref ke :kevent64.udata))))))
(defun kevent-filter (ke)
(kevent-rref ke :filter))
(defun kevent-flags (ke)
(kevent-rref ke :flags))
(defun kevent-data (ke)
(kevent-rref ke :data))
;; FILTER TYPES:
(eval-when (:compile-toplevel :load-toplevel :execute) ; added by binghe
(defconstant $kevent-read-filter -1 "Data available to read")
(defconstant $kevent-write-filter -2 "Writing is possible")
(defconstant $kevent-aio-filter -3 "AIO system call has been made")
(defconstant $kevent-vnode-filter -4 "Event occured on a file descriptor")
(defconstant $kevent-proc-filter -5 "Process performed one or more of the requested events")
(defconstant $kevent-signal-filter -6 "Attempted to deliver a signal to a process")
(defconstant $kevent-timer-filter -7 "Establishes an arbitrary timer")
(defconstant $kevent-netdev-filter -8 "Event occured on a network device")
(defconstant $kevent-filesystem-filter -9)
) ; eval-when
; FLAGS:
(defconstant $kevent-add #x01)
(defconstant $kevent-delete #x02)
(defconstant $kevent-enable #x04)
(defconstant $kevent-disable #x08)
(defconstant $kevent-oneshot #x10)
(defconstant $kevent-clear #x20)
(defconstant $kevent-error #x4000)
(defconstant $kevent-eof #x8000 "EV_EOF")
;; FFLAGS:
(defconstant $kevent-file-delete #x01 "The file was unlinked from the file system")
(defconstant $kevent-file-write #x02 "A write occurred on the file")
(defconstant $kevent-file-extend #x04 "The file was extended")
(defconstant $kevent-file-attrib #x08 "The file had its attributes changed")
(defconstant $kevent-file-link #x10 "The link count on the file changed")
(defconstant $kevent-file-rename #x20 "The file was renamed")
(defconstant $kevent-file-revoke #x40 "Access to the file was revoked or the file system was unmounted")
(defconstant $kevent-file-all (logior $kevent-file-delete $kevent-file-write $kevent-file-extend
$kevent-file-attrib $kevent-file-link $kevent-file-rename $kevent-file-revoke))
(defconstant $kevent-net-linkup #x01 "Link is up")
(defconstant $kevent-net-linkdown #x02 "Link is down")
(defconstant $kevent-net-linkinvalid #x04 "Link state is invalid")
(defconstant $kevent-net-added #x08 "IP adress added")
(defconstant $kevent-net-deleted #x10 "IP adress deleted")
(define-condition kevent-error (simple-error)
((errno :initform NIL :initarg :errno)
(ko :initform nil :type (or null kevent) :initarg :ko)
(syserr :initform (%system-errno)))
(:report
(lambda (c s)
(with-slots (errno ko syserr) c
(format s "kevent system call error ~A [~A]" errno syserr)
(when errno
(format s "(~A)" (%get-cstring (%system-strerror errno))))
(when ko
(format s " for ")
(let ((*standard-output* s))
(print-record ko *kevent-record*)))))))
(defun %kevent (kq &optional ke ko (timeout 0))
(check-type kq integer)
(rlet ((&timeout :timespec :sec timeout :usec 1))
(let ((num (with-timer ;; does not seem to make a difference...
(%system-kevent kq (or ke (%null-ptr))(if ke 1 0)(or ko (%null-ptr))(if ko 1 0) &timeout))))
; "If an error occurs while processing an element of the changelist and there
; is enough room in the eventlist, then the event will be placed in the eventlist with
; EV_ERROR set in flags and the system error in data."
(when (and ko (plusp (logand $kevent-error (kevent-flags ko))))
(error 'kevent-error
:errno (kevent-data ko)
:ko ko))
; "Otherwise, -1 will be returned, and errno will be set to indicate the error condition."
(when (= num -1)
;; hack - opentransport provides the constants for the errors documented for the call
(case (%system-errno)
(0 (error "kevent system call failed with an unspecified error")) ;; should not happen!
(13 (error "The process does not have permission to register a filter"))
(14 (error "There was an error reading or writing the kevent structure")) ; EFAULT
(9 (error "The specified descriptor is invalid")) ; EBADF
(4 (error "A signal was delivered before the timeout expired and before any events were placed on the kqueue for return.")) ; EINTR
(22 (error "The specified time limit or filter is invalid")) ; EINVAL
(2 (error "The event could not be found to be modified or deleted")) ; ENOENT
(12 (error "No memory was available to register the event")) ; ENOMEM
(78 (error "The specified process to attach to does not exist"))) ; ESRCH
;; shouldn't get here...
(errchk (%system-errno))
(error "error ~A" (%system-errno)))
(unless (zerop num)
(values ko num)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; CLOS INTERFACE
(defclass kqueue ()
((kq :initform (system-kqueue)
:documentation "file descriptor referencing the kqueue")
(fds :initform NIL)) ;; ## better if kept on top level, perhaps as a hash table...
(:documentation "A kernal event notification channel"))
(defmethod initialize-instance :after ((q kqueue) &rest rest)
(declare (ignore rest))
(terminate-when-unreachable q 'kqueue-close))
(defmethod kqueue-close ((q kqueue))
(with-slots (kq fds) q
(when (or kq fds) ;; allow repeated close
(system-close kq)
(setf fds NIL)
(setf kq NIL))))
(defmethod kqueue-poll ((q kqueue))
"Polls a kqueue for kevents"
;; may not have to be cleared, but just in case:
(flet ((kqueue-poll2 (ko)
(let ((result (with-slots (kq) q
(without-interrupts
(%kevent kq NIL ko)))))
(when result
(let ((type (kevent-filter result)))
(ecase type
(0 (values))
(#.$kevent-read-filter
(values
:read
(kevent-rref result :ident)
(kevent-rref result :flags)
(kevent-rref result :fflags)
(kevent-rref result :data)
(kevent-rref result :udata)))
(#.$kevent-write-filter :write)
(#.$kevent-aio-filter :aio)
(#.$kevent-vnode-filter
(values
:vnode
(cdr (assoc (kevent-rref result :ident) (slot-value q 'fds)))
(kevent-rref result :flags)
(kevent-rref result :fflags)
(kevent-rref result :data)
(kevent-rref result :udata)))
(#.$kevent-filesystem-filter :filesystem)))))))
(ecase *kevent-record*
(:kevent64
(rlet ((ko :kevent64 :ident 0 :filter 0 :flags 0 :fflags 0 :data 0 :udata (%null-ptr)))
(kqueue-poll2 ko)))
(:kevent32
(rlet ((ko :kevent32 :ident 0 :filter 0 :flags 0 :fflags 0 :data 0 :udata (%null-ptr)))
(kqueue-poll2 ko))))))
(defmethod kqueue-subscribe ((q kqueue) &key ident filter (flags 0) (fflags 0) (data 0) (udata (%null-ptr)))
(let ((ke (make-kevent :ident ident
:filter filter
:flags flags
:fflags fflags
:data data
:udata udata)))
(with-slots (kq) q
(without-interrupts
(%kevent kq ke)))))
(defmethod kqueue-vnode-subscribe ((q kqueue) pathname)
"Makes the queue report an event when there is a change to a directory or file"
(let* ((namestring (posix-namestring (full-pathname pathname)))
(fd (system-open namestring)))
(with-slots (fds) q
(push (cons fd pathname) fds))
(kqueue-subscribe q
:ident fd
:filter $kevent-vnode-filter
:flags (logior $kevent-add $kevent-clear)
:fflags $kevent-file-all)
namestring))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#+test
(defun kevent-d (pathname &optional (*standard-output* (fred)))
"Report changes to a file or directory"
(loop
with kqueue = (make-instance 'kqueue)
with sub = (kqueue-vnode-subscribe kqueue pathname)
for i from 1 to 60
for result = (multiple-value-list (kqueue-poll kqueue))
unless (equal result '(NIL))
do (progn
(format T "~A~%" result)
(force-output))
; do (process-allow-schedule)
do (sleep 1)
finally (write-line "Done")
))
#|
; Report changes to this file in a fred window (save this document to see what happens):
(process-run-function "kevent-d" #'kevent-d *loading-file-source-file*
(fred))
; Reports files added or removed from the directory of this file:
(process-run-function "kevent-d" #'kevent-d
(make-pathname :directory (pathname-directory *loading-file-source-file*))
(fred))
|#
\ No newline at end of file
More information about the usocket-cvs
mailing list