January 2010 - usocket-cvs@common-lisp.net

[usocket-cvs] r520 - usocket/trunk/backend
by Chun Tian 13 Jan '10

13 Jan '10

Author: ctian Date: Wed Jan 13 04:51:07 2010 New Revision: 520 Log: Patch from R. Matthew Emerson: report nameserver errors in the socket-creation-error condition object. Modified: usocket/trunk/backend/openmcl.lisp Modified: usocket/trunk/backend/openmcl.lisp ============================================================================== --- usocket/trunk/backend/openmcl.lisp (original) +++ usocket/trunk/backend/openmcl.lisp Wed Jan 13 04:51:07 2010 @@ -25,6 +25,10 @@ (:shutdown . shutdown-error) (:access-denied . operation-not-permitted-error))) +(defparameter +openmcl-nameserver-error-map+ + '((:no-recovery . ns-no-recovery-error) + (:try-again . ns-try-again-condition) + (:host-not-found . ns-host-not-found-error))) ;; we need something which the openmcl implementors 'forgot' to do: ;; wait for more than one socket-or-fd @@ -66,8 +70,12 @@ (ccl:communication-deadline-expired (error 'deadline-timeout-error :socket socket)) (ccl::socket-creation-error #| ugh! |# - (raise-error-from-id (ccl::socket-creation-error-identifier condition) - socket condition)))) + (let* ((condition-id (ccl::socket-creation-error-identifier condition)) + (nameserver-error (cdr (assoc condition-id + +openmcl-nameserver-error-map+)))) + (if nameserver-error + (error nameserver-error :host-or-ip nil) + (raise-error-from-id condition-id socket condition)))))) (defun to-format (element-type) (if (subtypep element-type 'character)

1 0

[usocket-cvs] r519 - usocket/trunk
by Chun Tian 13 Jan '10

13 Jan '10

Author: ctian Date: Wed Jan 13 04:48:05 2010 New Revision: 519 Log: ASDF dependency fixes Modified: usocket/trunk/usocket.asd Modified: usocket/trunk/usocket.asd ============================================================================== --- usocket/trunk/usocket.asd (original) +++ usocket/trunk/usocket.asd Wed Jan 13 04:48:05 2010 @@ -19,12 +19,12 @@ :description "Universal socket library for Common Lisp" :depends-on (#+sbcl :sb-bsd-sockets) :components ((:file "package") - (:module "vendor" + (:module "vendor" :depends-on ("package") :components ((:file "split-sequence") #+mcl (:file "kqueue"))) - (:file "usocket" :depends-on ("package" "vendor")) + (:file "usocket" :depends-on ("vendor")) (:file "condition" :depends-on ("usocket")) - (:module "backend" :depends-on ("usocket" "condition") + (:module "backend" :depends-on ("condition") :components (#+clisp (:file "clisp") #+cmu (:file "cmucl") #+scl (:file "scl")

1 0

[usocket-cvs] r518 - in usocket/trunk: . vendor
by Chun Tian 13 Jan '10

13 Jan '10

Author: ctian Date: Wed Jan 13 02:01:21 2010 New Revision: 518 Log: Remove dependency on split-sequence/cl-utilities, add as vendor code. Added: usocket/trunk/vendor/split-sequence.lisp (contents, props changed) Modified: usocket/trunk/usocket.asd usocket/trunk/usocket.lisp Modified: usocket/trunk/usocket.asd ============================================================================== --- usocket/trunk/usocket.asd (original) +++ usocket/trunk/usocket.asd Wed Jan 13 02:01:21 2010 @@ -11,25 +11,20 @@ (in-package #:usocket-system) -(pushnew :split-sequence-deprecated *features*) - (defsystem usocket :name "usocket" :author "Erik Enge & Erik Huelsmann" :version "0.5.0" :licence "MIT" :description "Universal socket library for Common Lisp" - :depends-on (;; :split-sequence - ;; use the splie-sequence from cl-utilities - :cl-utilities - #+sbcl :sb-bsd-sockets) + :depends-on (#+sbcl :sb-bsd-sockets) :components ((:file "package") - (:file "usocket" :depends-on ("package")) - (:file "condition" :depends-on ("usocket")) (:module "vendor" - :components (#+mcl (:file "kqueue"))) - (:module "backend" - :depends-on ("condition" "vendor") + :components ((:file "split-sequence") + #+mcl (:file "kqueue"))) + (:file "usocket" :depends-on ("package" "vendor")) + (:file "condition" :depends-on ("usocket")) + (:module "backend" :depends-on ("usocket" "condition") :components (#+clisp (:file "clisp") #+cmu (:file "cmucl") #+scl (:file "scl") Modified: usocket/trunk/usocket.lisp ============================================================================== --- usocket/trunk/usocket.lisp (original) +++ usocket/trunk/usocket.lisp Wed Jan 13 02:01:21 2010 @@ -399,14 +399,14 @@ (aref vector 3))) (defun dotted-quad-to-vector-quad (string) - (let ((list (list-of-strings-to-integers (split-sequence:split-sequence #\. string)))) + (let ((list (list-of-strings-to-integers (split-sequence #\. string)))) (vector (first list) (second list) (third list) (fourth list)))) (defgeneric host-byte-order (address)) (defmethod host-byte-order ((string string)) "Convert a string, such as 192.168.1.1, to host-byte-order, such as 3232235777." - (let ((list (list-of-strings-to-integers (split-sequence:split-sequence #\. string)))) + (let ((list (list-of-strings-to-integers (split-sequence #\. string)))) (+ (* (first list) 256 256 256) (* (second list) 256 256) (* (third list) 256) (fourth list)))) Added: usocket/trunk/vendor/split-sequence.lisp ============================================================================== --- (empty file) +++ usocket/trunk/vendor/split-sequence.lisp Wed Jan 13 02:01:21 2010 @@ -0,0 +1,245 @@ +;;;; SPLIT-SEQUENCE +;;; +;;; This code was based on Arthur Lemmens' in +;;; <URL:http://groups.google.com/groups?as_umsgid=39F36F1A.B8F19D20%40simplex.nl>; +;;; +;;; changes include: +;;; +;;; * altering the behaviour of the :from-end keyword argument to +;;; return the subsequences in original order, for consistency with +;;; CL:REMOVE, CL:SUBSTITUTE et al. (:from-end being non-NIL only +;;; affects the answer if :count is less than the number of +;;; subsequences, by analogy with the above-referenced functions). +;;; +;;; * changing the :maximum keyword argument to :count, by analogy +;;; with CL:REMOVE, CL:SUBSTITUTE, and so on. +;;; +;;; * naming the function SPLIT-SEQUENCE rather than PARTITION rather +;;; than SPLIT. +;;; +;;; * adding SPLIT-SEQUENCE-IF and SPLIT-SEQUENCE-IF-NOT. +;;; +;;; * The second return value is now an index rather than a copy of a +;;; portion of the sequence; this index is the `right' one to feed to +;;; CL:SUBSEQ for continued processing. + +;;; There's a certain amount of code duplication here, which is kept +;;; to illustrate the relationship between the SPLIT-SEQUENCE +;;; functions and the CL:POSITION functions. + +;;; Examples: +;;; +;;; * (split-sequence #\; "a;;b;c") +;;; -> ("a" "" "b" "c"), 6 +;;; +;;; * (split-sequence #\; "a;;b;c" :from-end t) +;;; -> ("a" "" "b" "c"), 0 +;;; +;;; * (split-sequence #\; "a;;b;c" :from-end t :count 1) +;;; -> ("c"), 4 +;;; +;;; * (split-sequence #\; "a;;b;c" :remove-empty-subseqs t) +;;; -> ("a" "b" "c"), 6 +;;; +;;; * (split-sequence-if (lambda (x) (member x '(#\a #\b))) "abracadabra") +;;; -> ("" "" "r" "c" "d" "" "r" ""), 11 +;;; +;;; * (split-sequence-if-not (lambda (x) (member x '(#\a #\b))) "abracadabra") +;;; -> ("ab" "a" "a" "ab" "a"), 11 +;;; +;;; * (split-sequence #\; ";oo;bar;ba;" :start 1 :end 9) +;;; -> ("oo" "bar" "b"), 9 + +#+ignore ; comment by usocket +(defpackage "SPLIT-SEQUENCE" + (:use "CL") + (:nicknames "PARTITION") + (:export "SPLIT-SEQUENCE" "SPLIT-SEQUENCE-IF" "SPLIT-SEQUENCE-IF-NOT" + "PARTITION" "PARTITION-IF" "PARTITION-IF-NOT")) + +(in-package :usocket #+ignore "SPLIT-SEQUENCE") + +(defun split-sequence (delimiter seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (test nil test-supplied) (test-not nil test-not-supplied) (key nil key-supplied)) + "Return a list of subsequences in seq delimited by delimiter. + +If :remove-empty-subseqs is NIL, empty subsequences will be included +in the result; otherwise they will be discarded. All other keywords +work analogously to those for CL:SUBSTITUTE. In particular, the +behaviour of :from-end is possibly different from other versions of +this function; :from-end values of NIL and T are equivalent unless +:count is supplied. The second return value is an index suitable as an +argument to CL:SUBSEQ into the sequence indicating where processing +stopped." + (let ((len (length seq)) + (other-keys (nconc (when test-supplied + (list :test test)) + (when test-not-supplied + (list :test-not test-not)) + (when key-supplied + (list :key key))))) + (unless end (setq end len)) + (if from-end + (loop for right = end then left + for left = (max (or (apply #'position delimiter seq + :end right + :from-end t + other-keys) + -1) + (1- start)) + unless (and (= right (1+ left)) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values (nreverse subseqs) right) + else + collect (subseq seq (1+ left) right) into subseqs + and sum 1 into nr-elts + until (< left start) + finally (return (values (nreverse subseqs) (1+ left)))) + (loop for left = start then (+ right 1) + for right = (min (or (apply #'position delimiter seq + :start left + other-keys) + len) + end) + unless (and (= right left) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values subseqs left) + else + collect (subseq seq left right) into subseqs + and sum 1 into nr-elts + until (>= right end) + finally (return (values subseqs right)))))) + +(defun split-sequence-if (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied)) + "Return a list of subsequences in seq delimited by items satisfying +predicate. + +If :remove-empty-subseqs is NIL, empty subsequences will be included +in the result; otherwise they will be discarded. All other keywords +work analogously to those for CL:SUBSTITUTE-IF. In particular, the +behaviour of :from-end is possibly different from other versions of +this function; :from-end values of NIL and T are equivalent unless +:count is supplied. The second return value is an index suitable as an +argument to CL:SUBSEQ into the sequence indicating where processing +stopped." + (let ((len (length seq)) + (other-keys (when key-supplied + (list :key key)))) + (unless end (setq end len)) + (if from-end + (loop for right = end then left + for left = (max (or (apply #'position-if predicate seq + :end right + :from-end t + other-keys) + -1) + (1- start)) + unless (and (= right (1+ left)) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values (nreverse subseqs) right) + else + collect (subseq seq (1+ left) right) into subseqs + and sum 1 into nr-elts + until (< left start) + finally (return (values (nreverse subseqs) (1+ left)))) + (loop for left = start then (+ right 1) + for right = (min (or (apply #'position-if predicate seq + :start left + other-keys) + len) + end) + unless (and (= right left) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values subseqs left) + else + collect (subseq seq left right) into subseqs + and sum 1 into nr-elts + until (>= right end) + finally (return (values subseqs right)))))) + +(defun split-sequence-if-not (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied)) + "Return a list of subsequences in seq delimited by items satisfying +(CL:COMPLEMENT predicate). + +If :remove-empty-subseqs is NIL, empty subsequences will be included +in the result; otherwise they will be discarded. All other keywords +work analogously to those for CL:SUBSTITUTE-IF-NOT. In particular, +the behaviour of :from-end is possibly different from other versions +of this function; :from-end values of NIL and T are equivalent unless +:count is supplied. The second return value is an index suitable as an +argument to CL:SUBSEQ into the sequence indicating where processing +stopped." + (let ((len (length seq)) + (other-keys (when key-supplied + (list :key key)))) + (unless end (setq end len)) + (if from-end + (loop for right = end then left + for left = (max (or (apply #'position-if-not predicate seq + :end right + :from-end t + other-keys) + -1) + (1- start)) + unless (and (= right (1+ left)) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values (nreverse subseqs) right) + else + collect (subseq seq (1+ left) right) into subseqs + and sum 1 into nr-elts + until (< left start) + finally (return (values (nreverse subseqs) (1+ left)))) + (loop for left = start then (+ right 1) + for right = (min (or (apply #'position-if-not predicate seq + :start left + other-keys) + len) + end) + unless (and (= right left) + remove-empty-subseqs) ; empty subseq we don't want + if (and count (>= nr-elts count)) + ;; We can't take any more. Return now. + return (values subseqs left) + else + collect (subseq seq left right) into subseqs + and sum 1 into nr-elts + until (>= right end) + finally (return (values subseqs right)))))) + +;;; clean deprecation + +(defun partition (&rest args) + (apply #'split-sequence args)) + +(defun partition-if (&rest args) + (apply #'split-sequence-if args)) + +(defun partition-if-not (&rest args) + (apply #'split-sequence-if-not args)) + +(define-compiler-macro partition (&whole form &rest args) + (declare (ignore args)) + (warn "PARTITION is deprecated; use SPLIT-SEQUENCE instead.") + form) + +(define-compiler-macro partition-if (&whole form &rest args) + (declare (ignore args)) + (warn "PARTITION-IF is deprecated; use SPLIT-SEQUENCE-IF instead.") + form) + +(define-compiler-macro partition-if-not (&whole form &rest args) + (declare (ignore args)) + (warn "PARTITION-IF-NOT is deprecated; use SPLIT-SEQUENCE-IF-NOT instead") + form) + +#+ignore ; comment by usocket +(pushnew :split-sequence *features*)

1 0

[usocket-cvs] r517 - usocket/branches/0.4.x/backend
by Chun Tian 07 Jan '10

07 Jan '10

Author: ctian Date: Thu Jan 7 18:49:04 2010 New Revision: 517 Log: merge from trunk (r509) Modified: usocket/branches/0.4.x/backend/openmcl.lisp Modified: usocket/branches/0.4.x/backend/openmcl.lisp ============================================================================== --- usocket/branches/0.4.x/backend/openmcl.lisp (original) +++ usocket/branches/0.4.x/backend/openmcl.lisp Thu Jan 7 18:49:04 2010 @@ -85,8 +85,7 @@ :format (to-format element-type) :deadline deadline :nodelay nodelay - :connect-timeout (and timeout - (* timeout internal-time-units-per-second))))) + :connect-timeout timeout))) (openmcl-socket:socket-connect mcl-sock) (make-stream-socket :stream mcl-sock :socket mcl-sock))))

1 0

[usocket-cvs] r516 - in usocket/branches/0.4.x: . backend
by Chun Tian 07 Jan '10

07 Jan '10

Author: ctian Date: Thu Jan 7 18:47:11 2010 New Revision: 516 Log: merge bugfix from trunk (r496-504) Modified: usocket/branches/0.4.x/backend/openmcl.lisp usocket/branches/0.4.x/backend/sbcl.lisp usocket/branches/0.4.x/condition.lisp Modified: usocket/branches/0.4.x/backend/openmcl.lisp ============================================================================== --- usocket/branches/0.4.x/backend/openmcl.lisp (original) +++ usocket/branches/0.4.x/backend/openmcl.lisp Thu Jan 7 18:47:11 2010 @@ -62,9 +62,9 @@ (raise-error-from-id (openmcl-socket:socket-error-identifier condition) socket condition)) (ccl:input-timeout - (error 'timeout-error :socket socket :real-error condition)) + (error 'timeout-error :socket socket)) (ccl:communication-deadline-expired - (error 'deadline-error :socket socket :real-error condition)) + (error 'deadline-timeout-error :socket socket)) (ccl::socket-creation-error #| ugh! |# (raise-error-from-id (ccl::socket-creation-error-identifier condition) socket condition)))) @@ -123,10 +123,14 @@ (close (socket usocket)))) (defmethod get-local-address ((usocket usocket)) - (hbo-to-vector-quad (openmcl-socket:local-host (socket usocket)))) + (let ((address (openmcl-socket:local-host (socket usocket)))) + (when address + (hbo-to-vector-quad address)))) (defmethod get-peer-address ((usocket stream-usocket)) - (hbo-to-vector-quad (openmcl-socket:remote-host (socket usocket)))) + (let ((address (openmcl-socket:remote-host (socket usocket)))) + (when address + (hbo-to-vector-quad address)))) (defmethod get-local-port ((usocket usocket)) (openmcl-socket:local-port (socket usocket))) Modified: usocket/branches/0.4.x/backend/sbcl.lisp ============================================================================== --- usocket/branches/0.4.x/backend/sbcl.lisp (original) +++ usocket/branches/0.4.x/backend/sbcl.lisp Thu Jan 7 18:47:11 2010 @@ -50,7 +50,8 @@ "#include <winsock2.h>") (ffi:clines - "#include <sys/time.h>" + #+:msvc "#include <time.h>" + #-:msvc "#include <sys/time.h>" "#include <ecl/ecl-inl.h>") #+:prefixed-api @@ -174,6 +175,8 @@ . socket-type-not-supported-error) (sb-bsd-sockets:network-unreachable-error . network-unreachable-error) (sb-bsd-sockets:operation-timeout-error . timeout-error) + #-ecl + (sb-sys:io-timeout . timeout-error) (sb-bsd-sockets:socket-error . ,#'map-socket-error) ;; Nameservice errors: mapped to unknown-error Modified: usocket/branches/0.4.x/condition.lisp ============================================================================== --- usocket/branches/0.4.x/condition.lisp (original) +++ usocket/branches/0.4.x/condition.lisp Thu Jan 7 18:47:11 2010 @@ -111,6 +111,7 @@ host-unreachable-error shutdown-error timeout-error + deadline-timeout-error invalid-socket-error invalid-socket-stream-error) (socket-error)) @@ -183,7 +184,7 @@ ((49 99) . address-not-available-error) ((9) . bad-file-descriptor-error) ((61 111) . connection-refused-error) - ((64 131) . connection-reset-error) + ((54 104) . connection-reset-error) ((53 103) . connection-aborted-error) ((22) . invalid-argument-error) ((55 105) . no-buffers-error)

1 0

[usocket-cvs] r515 - in usocket/trunk: . backend
by Chun Tian 07 Jan '10

07 Jan '10

Author: ctian Date: Thu Jan 7 13:26:06 2010 New Revision: 515 Log: Branch experimental-udp merged into trunk. Added: usocket/trunk/server.lisp - copied unchanged from r514, /usocket/branches/experimental-udp/server.lisp Modified: usocket/trunk/backend/allegro.lisp usocket/trunk/backend/armedbear.lisp usocket/trunk/backend/clisp.lisp usocket/trunk/backend/cmucl.lisp usocket/trunk/backend/lispworks.lisp usocket/trunk/backend/openmcl.lisp usocket/trunk/backend/sbcl.lisp usocket/trunk/backend/scl.lisp usocket/trunk/package.lisp usocket/trunk/usocket.asd usocket/trunk/usocket.lisp Modified: usocket/trunk/backend/allegro.lisp ============================================================================== --- usocket/trunk/backend/allegro.lisp (original) +++ usocket/trunk/backend/allegro.lisp Thu Jan 7 13:26:06 2010 @@ -49,7 +49,7 @@ :text :binary)) -(defun socket-connect (host port &key (element-type 'character) +(defun socket-connect (host port &key (protocol :stream) (element-type 'character) timeout deadline (nodelay t) ;; nodelay == t is the ACL default local-host local-port) @@ -58,20 +58,39 @@ (let ((socket)) (setf socket - (labels ((make-socket () - (socket:make-socket :remote-host (host-to-hostname host) - :remote-port port - :local-host (when local-host - (host-to-hostname local-host)) - :local-port local-port - :format (to-format element-type) - :nodelay nodelay))) - (with-mapped-conditions (socket) - (if timeout - (mp:with-timeout (timeout nil) - (make-socket)) - (make-socket))))) - (make-stream-socket :socket socket :stream socket))) + (with-mapped-conditions (socket) + (ecase protocol + (:stream + (labels ((make-socket () + (socket:make-socket :remote-host (host-to-hostname host) + :remote-port port + :local-host (when local-host + (host-to-hostname local-host)) + :local-port local-port + :format (to-format element-type) + :nodelay nodelay))) + (if timeout + (mp:with-timeout (timeout nil) + (make-socket)) + (make-socket)))) + (:datagram + (apply #'socket:make-socket + (nconc (list :type protocol + :address-family :internet + :local-host (when local-host + (host-to-hostname local-host)) + :local-port local-port + :format (to-format element-type)) + (if (and host port) + (list :connect :active + :remote-host (host-to-hostname host) + :remote-port port) + (list :connect :passive)))))))) + (ecase protocol + (:stream + (make-stream-socket :socket socket :stream socket)) + (:datagram + (make-datagram-socket socket))))) ;; One socket close method is sufficient, ;; because socket-streams are also sockets. @@ -130,6 +149,15 @@ (values (get-peer-address usocket) (get-peer-port usocket))) +(defmethod socket-send ((socket datagram-usocket) buffer length &key host port) + (with-mapped-conditions (socket) + (let ((s (socket socket))) + (socket:send-to s buffer length :remote-host host :remote-port port)))) + +(defmethod socket-receive ((socket datagram-usocket) buffer length &key) + (with-mapped-conditions (socket) + (let ((s (socket socket))) + (socket:receive-from s length :buffer buffer :extract t)))) (defun get-host-by-address (address) (with-mapped-conditions () Modified: usocket/trunk/backend/armedbear.lisp ============================================================================== --- usocket/trunk/backend/armedbear.lisp (original) +++ usocket/trunk/backend/armedbear.lisp Thu Jan 7 13:26:06 2010 @@ -6,7 +6,7 @@ (in-package :usocket) -;;;;; Proposed contribution to the JAVA package +;;; Proposed contribution to the JAVA package (defpackage :jdi (:use :cl) @@ -186,24 +186,36 @@ (typecase condition (error (error 'unknown-error :socket socket :real-error condition)))) -(defun socket-connect (host port &key (element-type 'character) +(defun socket-connect (host port &key (protocol :stream) (element-type 'character) timeout deadline (nodelay nil nodelay-specified) local-host local-port) (when deadline (unsupported 'deadline 'socket-connect)) - (when local-host (unimplemented 'local-host 'socket-connect)) - (when local-port (unimplemented 'local-port 'socket-connect)) (let ((usock)) (with-mapped-conditions (usock) - (let* ((sock-addr (jdi:jcoerce - (jdi:do-jnew-call "java.net.InetSocketAddress" - (host-to-hostname host) - (jdi:jcoerce port :int)) - "java.net.SocketAddress")) - (jchan (jdi:do-jstatic-call "java.nio.channels.SocketChannel" - "open" sock-addr)) + (let* ((sock-addr (when (and host port) + (jdi:jcoerce + (jdi:do-jnew-call "java.net.InetSocketAddress" + (host-to-hostname host) + (jdi:jcoerce port :int)) + "java.net.SocketAddress"))) + (local-addr (when (or local-host local-port) + (jdi:jcoerce + (jdi:do-jnew-call "java.net.InetSocketAddress" + (host-to-hostname (or host *wildcard-host*)) + (jdi:jcoerce (or port *auto-port*) :int)) + "java.net.SocketAddress"))) + (jchan (jdi:do-jstatic-call (ecase protocol + (:stream "java.nio.channels.SocketChannel") + (:datagram "java.nio.channels.DatagramChannel")) + "open")) (sock (jdi:do-jmethod-call jchan "socket"))) - (when nodelay-specified + ;; TODO: Fix it + (when (or local-host local-port) + (jdi:do-jmethod-call sock "bind" local-addr)) + (when (and host port) + (jdi:do-jmethod-call jchan "connect" sock-addr)) + (when (and (eq protocol 'stream) nodelay-specified) (jdi:do-jmethod-call sock "setTcpNoDelay" (if nodelay (java:make-immediate-object t :boolean) @@ -212,10 +224,14 @@ (jdi:do-jmethod-call sock "setSoTimeout" (truncate (* 1000 timeout)))) (setf usock - (make-stream-socket - :socket jchan - :stream (ext:get-socket-stream (jdi:jop-deref sock) - :element-type element-type))))))) + (ecase protocol + (:stream + (make-stream-socket + :socket jchan + :stream (ext:get-socket-stream (jdi:jop-deref sock) + :element-type element-type))) + (:datagram + (make-datagram-socket jchan)))))))) (defun socket-listen (host port &key reuseaddress @@ -447,4 +463,29 @@ w)) (defun %remove-waiter (wl w) - (remhash (socket w) (wait-list-%wait wl))) \ No newline at end of file + (remhash (socket w) (wait-list-%wait wl))) + +;; +;; UDP support +;; + +(defmethod socket-send ((socket datagram-usocket) buffer length &key host port) + (let ((jchan (socket socket))) + (let ((srcs (jdi:jcoerce buffer "java.nio.ByteBuffer")) + (offset (jdi:jcoerce 0 :int)) + (length (jdi:jcoerce length :int))) + (if (and host port) + (let ((target (jdi:jcoerce + (jdi:do-jnew-call "java.net.InetSocketAddress" + (host-to-hostname host) + (jdi:jcoerce port :int)) + "java.net.SocketAddress"))) + ;; how to use "length" argument here? --binghe, 2009/12/12 + (jdi:do-jmethod-call jchan "send" buffer target)) + (jdi:do-jmethod-call jchan "write" srcs offset length))))) + +(defmethod socket-receive ((socket datagram-usocket) buffer length &key) + (let ((jchan (socket socket))) + (multiple-value-bind (buffer size host port) + 0 + (values buffer size host port)))) Modified: usocket/trunk/backend/clisp.lisp ============================================================================== --- usocket/trunk/backend/clisp.lisp (original) +++ usocket/trunk/backend/clisp.lisp Thu Jan 7 13:26:06 2010 @@ -55,7 +55,7 @@ (error usock-err :socket socket) (signal usock-err :socket socket))))))) -(defun socket-connect (host port &key (element-type 'character) +(defun socket-connect (host port &key (protocol :stream) (element-type 'character) timeout deadline (nodelay t nodelay-specified) local-host local-port) (declare (ignore nodelay)) Modified: usocket/trunk/backend/cmucl.lisp ============================================================================== --- usocket/trunk/backend/cmucl.lisp (original) +++ usocket/trunk/backend/cmucl.lisp Thu Jan 7 13:26:06 2010 @@ -50,7 +50,7 @@ :socket socket :condition condition)))) -(defun socket-connect (host port &key (element-type 'character) +(defun socket-connect (host port &key (protocol :stream) (element-type 'character) timeout deadline (nodelay t nodelay-specified) (local-host nil local-host-p) (local-port nil local-port-p) @@ -65,25 +65,53 @@ (when (and local-port-p (not local-bind-p)) (unsupported 'local-port 'socket-connect :minimum "Snapshot 2008-08 (19E)")) - (let* ((socket)) - (setf socket - (let ((args (list (host-to-hbo host) port :stream))) - (when (and local-bind-p (or local-host-p local-port-p)) - (nconc args (list :local-host (when local-host - (host-to-hbo local-host)) - :local-port local-port))) - (with-mapped-conditions (socket) - (apply #'ext:connect-to-inet-socket args)))) - (if socket - (let* ((stream (sys:make-fd-stream socket :input t :output t - :element-type element-type - :buffering :full)) - ;;###FIXME the above line probably needs an :external-format - (usocket (make-stream-socket :socket socket - :stream stream))) - usocket) - (let ((err (unix:unix-errno))) - (when err (cmucl-map-socket-error err)))))) + (let ((socket)) + (ecase protocol + (:stream + (setf socket + (let ((args (list (host-to-hbo host) port protocol))) + (when (and local-bind-p (or local-host-p local-port-p)) + (nconc args (list :local-host (when local-host + (host-to-hbo local-host)) + :local-port local-port))) + (with-mapped-conditions (socket) + (apply #'ext:connect-to-inet-socket args)))) + (if socket + (let* ((stream (sys:make-fd-stream socket :input t :output t + :element-type element-type + :buffering :full)) + ;;###FIXME the above line probably needs an :external-format + (usocket (make-stream-socket :socket socket + :stream stream))) + usocket) + (let ((err (unix:unix-errno))) + (when err (cmucl-map-socket-error err))))) + (:datagram + (setf socket + (if (and host port) + (let ((args (list (host-to-hbo host) port protocol))) + (when (and local-bind-p (or local-host-p local-port-p)) + (nconc args (list :local-host (when local-host + (host-to-hbo local-host)) + :local-port local-port))) + (with-mapped-conditions (socket) + (apply #'ext:connect-to-inet-socket args))) + (if (or local-host-p local-port-p) + (with-mapped-conditions (socket) + (apply #'ext:create-inet-listener + (nconc (list (or local-port 0) protocol) + (when (and local-host-p + (ip/= local-host *wildcard-host*)) + (list :host (host-to-hbo local-host)))))) + (with-mapped-conditions (socket) + (ext:create-inet-socket protocol))))) + (if socket + (let ((usocket (make-datagram-socket socket))) + (ext:finalize usocket #'(lambda () (when (%open-p usocket) + (ext:close-socket socket)))) + usocket) + (let ((err (unix:unix-errno))) + (when err (cmucl-map-socket-error err)))))))) (defun socket-listen (host port &key reuseaddress @@ -128,6 +156,24 @@ (with-mapped-conditions (usocket) (ext:close-socket (socket usocket)))) +(defmethod socket-close :after ((socket datagram-usocket)) + (setf (%open-p socket) nil)) + +(defmethod socket-send ((usocket datagram-usocket) buffer length &key host port) + (with-mapped-conditions (usocket) + (ext:inet-sendto (socket usocket) buffer length (if host (host-to-hbo host)) port))) + +(defmethod socket-receive ((usocket datagram-usocket) buffer length &key) + (let ((real-buffer (or buffer + (make-array length :element-type '(unsigned-byte 8)))) + (real-length (or length + (length buffer)))) + (multiple-value-bind (nbytes remote-host remote-port) + (with-mapped-conditions (usocket) + (ext:inet-recvfrom (socket usocket) real-buffer real-length)) + (when (plusp nbytes) + (values real-buffer nbytes remote-host remote-port))))) + (defmethod get-local-name ((usocket usocket)) (multiple-value-bind (address port) @@ -216,5 +262,5 @@ (when (unix:fd-isset (socket x) rfds) (setf (state x) :READ))) (progn - ;;###FIXME generate an error, except for EINTR + ;;###FIXME generate an error, except for EINTR ))))))) Modified: usocket/trunk/backend/lispworks.lisp ============================================================================== --- usocket/trunk/backend/lispworks.lisp (original) +++ usocket/trunk/backend/lispworks.lisp Thu Jan 7 13:26:06 2010 @@ -89,15 +89,172 @@ (declare (ignore host port err-msg)) (raise-usock-err errno socket condition))))) -(defun socket-connect (host port &key (element-type 'base-char) +(defconstant *socket_sock_dgram* 2 + "Connectionless, unreliable datagrams of fixed maximum length.") + +(defconstant *sockopt_so_rcvtimeo* + #+(not linux) #x1006 + #+linux 20 + "Socket receive timeout") + +(fli:define-c-struct timeval + (tv-sec :long) + (tv-usec :long)) + +;;; ssize_t +;;; recvfrom(int socket, void *restrict buffer, size_t length, int flags, +;;; struct sockaddr *restrict address, socklen_t *restrict address_len); +(fli:define-foreign-function (%recvfrom "recvfrom" :source) + ((socket :int) + (buffer (:pointer (:unsigned :byte))) + (length :int) + (flags :int) + (address (:pointer (:struct comm::sockaddr))) + (address-len (:pointer :int))) + :result-type :int + #+win32 :module + #+win32 "ws2_32") + +;;; ssize_t +;;; sendto(int socket, const void *buffer, size_t length, int flags, +;;; const struct sockaddr *dest_addr, socklen_t dest_len); +(fli:define-foreign-function (%sendto "sendto" :source) + ((socket :int) + (buffer (:pointer (:unsigned :byte))) + (length :int) + (flags :int) + (address (:pointer (:struct comm::sockaddr))) + (address-len :int)) + :result-type :int + #+win32 :module + #+win32 "ws2_32") + +#-win32 +(defun set-socket-receive-timeout (socket-fd seconds) + "Set socket option: RCVTIMEO, argument seconds can be a float number" + (declare (type integer socket-fd) + (type number seconds)) + (multiple-value-bind (sec usec) (truncate seconds) + (fli:with-dynamic-foreign-objects ((timeout (:struct timeval))) + (fli:with-foreign-slots (tv-sec tv-usec) timeout + (setf tv-sec sec + tv-usec (truncate (* 1000000 usec))) + (if (zerop (comm::setsockopt socket-fd + comm::*sockopt_sol_socket* + *sockopt_so_rcvtimeo* + (fli:copy-pointer timeout + :type '(:pointer :void)) + (fli:size-of '(:struct timeval)))) + seconds))))) + +#+win32 +(defun set-socket-receive-timeout (socket-fd seconds) + "Set socket option: RCVTIMEO, argument seconds can be a float number. + On win32, you must bind the socket before use this function." + (declare (type integer socket-fd) + (type number seconds)) + (fli:with-dynamic-foreign-objects ((timeout :int)) + (setf (fli:dereference timeout) + (truncate (* 1000 seconds))) + (if (zerop (comm::setsockopt socket-fd + comm::*sockopt_sol_socket* + *sockopt_so_rcvtimeo* + (fli:copy-pointer timeout + :type '(:pointer :char)) + (fli:size-of :int))) + seconds))) + +#-win32 +(defmethod get-socket-receive-timeout (socket-fd) + "Get socket option: RCVTIMEO, return value is a float number" + (declare (type integer socket-fd)) + (fli:with-dynamic-foreign-objects ((timeout (:struct timeval)) + (len :int)) + (comm::getsockopt socket-fd + comm::*sockopt_sol_socket* + *sockopt_so_rcvtimeo* + (fli:copy-pointer timeout + :type '(:pointer :void)) + len) + (fli:with-foreign-slots (tv-sec tv-usec) timeout + (float (+ tv-sec (/ tv-usec 1000000)))))) + +#+win32 +(defmethod get-socket-receive-timeout (socket-fd) + "Get socket option: RCVTIMEO, return value is a float number" + (declare (type integer socket-fd)) + (fli:with-dynamic-foreign-objects ((timeout :int) + (len :int)) + (comm::getsockopt socket-fd + comm::*sockopt_sol_socket* + *sockopt_so_rcvtimeo* + (fli:copy-pointer timeout + :type '(:pointer :void)) + len) + (float (/ (fli:dereference timeout) 1000)))) + +(defun open-udp-socket (&key local-address local-port read-timeout) + "Open a unconnected UDP socket. + For binding on address ANY(*), just not set LOCAL-ADDRESS (NIL), + for binding on random free unused port, set LOCAL-PORT to 0." + (let ((socket-fd (comm::socket comm::*socket_af_inet* *socket_sock_dgram* comm::*socket_pf_unspec*))) + (if socket-fd + (progn + (when read-timeout (set-socket-receive-timeout socket-fd read-timeout)) + (if local-port + (fli:with-dynamic-foreign-objects ((client-addr (:struct comm::sockaddr_in))) + (comm::initialize-sockaddr_in client-addr comm::*socket_af_inet* + local-address local-port "udp") + (if (comm::bind socket-fd + (fli:copy-pointer client-addr :type '(:struct comm::sockaddr)) + (fli:pointer-element-size client-addr)) + ;; success, return socket fd + socket-fd + (progn + (comm::close-socket socket-fd) + (error "cannot bind")))) + socket-fd)) + (error "cannot create socket")))) + +(defun connect-to-udp-server (hostname service + &key local-address local-port read-timeout) + "Something like CONNECT-TO-TCP-SERVER" + (let ((socket-fd (open-udp-socket :local-address local-address + :local-port local-port + :read-timeout read-timeout))) + (if socket-fd + (fli:with-dynamic-foreign-objects ((server-addr (:struct comm::sockaddr_in))) + ;; connect to remote address/port + (comm::initialize-sockaddr_in server-addr comm::*socket_af_inet* hostname service "udp") + (if (comm::connect socket-fd + (fli:copy-pointer server-addr :type '(:struct comm::sockaddr)) + (fli:pointer-element-size server-addr)) + ;; success, return socket fd + socket-fd + ;; fail, close socket and return nil + (progn + (comm::close-socket socket-fd) + (error "cannot connect")))) + (error "cannot create socket")))) + +;; Register a special free action for closing datagram usocket when being GCed +(defun usocket-special-free-action (object) + (when (and (typep object 'datagram-usocket) + (%open-p object)) + (socket-close object))) + +(eval-when (:load-toplevel :execute) + (hcl:add-special-free-action 'usocket-special-free-action)) + +(defun socket-connect (host port &key (protocol :stream) (element-type 'base-char) timeout deadline (nodelay t nodelay-specified) - local-host local-port) + local-host (local-port #+win32 *auto-port* #-win32 nil)) (declare (ignorable nodelay)) ;; What's the meaning of this keyword? (when deadline (unimplemented 'deadline 'socket-connect)) - + #+(and lispworks4 (not lispworks4.4)) ; < 4.4.5 (when timeout (unsupported 'timeout 'socket-connect :minimum "LispWorks 4.4.5")) @@ -112,26 +269,39 @@ (when local-port (unsupported 'local-port 'socket-connect :minimum "LispWorks 5.0")) - (let ((hostname (host-to-hostname host)) - (stream)) - (setf stream - (with-mapped-conditions () - (comm:open-tcp-stream hostname port - :element-type element-type - #-(and lispworks4 (not lispworks4.4)) ; >= 4.4.5 - #-(and lispworks4 (not lispworks4.4)) - :timeout timeout - #-lispworks4 #-lispworks4 - #-lispworks4 #-lispworks4 - :local-address (when local-host (host-to-hostname local-host)) - :local-port local-port - #-(or lispworks4 lispworks5.0) ; >= 5.1 - #-(or lispworks4 lispworks5.0) - :nodelay nodelay))) - (if stream - (make-stream-socket :socket (comm:socket-stream-socket stream) - :stream stream) - (error 'unknown-error)))) + (ecase protocol + (:stream + (let ((hostname (host-to-hostname host)) + (stream)) + (setf stream + (with-mapped-conditions () + (comm:open-tcp-stream hostname port + :element-type element-type + #-(and lispworks4 (not lispworks4.4)) ; >= 4.4.5 + #-(and lispworks4 (not lispworks4.4)) + :timeout timeout + #-lispworks4 #-lispworks4 + #-lispworks4 #-lispworks4 + :local-address (when local-host (host-to-hostname local-host)) + :local-port local-port + #-(or lispworks4 lispworks5.0) ; >= 5.1 + #-(or lispworks4 lispworks5.0) + :nodelay nodelay))) + (if stream + (make-stream-socket :socket (comm:socket-stream-socket stream) + :stream stream) + (error 'unknown-error)))) + (:datagram + (let ((usocket (make-datagram-socket + (if (and host port) + (connect-to-udp-server host port + :local-address local-host + :local-port local-port) + (open-udp-socket :local-address local-host + :local-port local-port)) + :connected-p t))) + (hcl:flag-special-free-action usocket) + usocket)))) (defun socket-listen (host port &key reuseaddress @@ -180,6 +350,107 @@ (with-mapped-conditions (usocket) (comm::close-socket (socket usocket)))) +(defmethod socket-close :after ((socket datagram-usocket)) + "Additional socket-close method for datagram-usocket" + (setf (%open-p socket) nil)) + +(defvar *message-send-buffer* + (make-array +max-datagram-packet-size+ + :element-type '(unsigned-byte 8) + :allocation :static)) + +(defvar *message-send-lock* (mp:make-lock)) + +(defun send-message (socket-fd buffer &optional (length (length buffer)) host service) + "Send message to a socket, using sendto()/send()" + (declare (type integer socket-fd) + (type sequence buffer)) + (let ((message *message-send-buffer*)) + (fli:with-dynamic-foreign-objects ((client-addr (:struct comm::sockaddr_in)) + (len :int + #-(or lispworks3 lispworks4 lispworks5.0) + :initial-element + (fli:size-of '(:struct comm::sockaddr_in)))) + (fli:with-dynamic-lisp-array-pointer (ptr message :type '(:unsigned :byte)) + (mp:with-lock (*message-send-lock*) + (replace message buffer :end2 length) + (if (and host service) + (progn + (comm::initialize-sockaddr_in client-addr comm::*socket_af_inet* host service "udp") + (%sendto socket-fd ptr (min length +max-datagram-packet-size+) 0 + (fli:copy-pointer client-addr :type '(:struct comm::sockaddr)) + (fli:dereference len))) + (comm::%send socket-fd ptr (min length +max-datagram-packet-size+) 0))))))) + +(defmethod socket-send ((socket datagram-usocket) buffer length &key host port) + (let ((s (socket socket))) + (send-message s buffer length (host-to-hbo host) port))) + +(defvar *message-receive-buffer* + (make-array +max-datagram-packet-size+ + :element-type '(unsigned-byte 8) + :allocation :static)) + +(defvar *message-receive-lock* (mp:make-lock)) + +(defun receive-message (socket-fd &optional buffer (length (length buffer)) + &key read-timeout (max-buffer-size +max-datagram-packet-size+)) + "Receive message from socket, read-timeout is a float number in seconds. + + This function will return 4 values: + 1. receive buffer + 2. number of receive bytes + 3. remote address + 4. remote port" + (declare (type integer socket-fd) + (type sequence buffer)) + (let ((message *message-receive-buffer*) + old-timeout) + (fli:with-dynamic-foreign-objects ((client-addr (:struct comm::sockaddr_in)) + (len :int + #-(or lispworks3 lispworks4 lispworks5.0) + :initial-element + (fli:size-of '(:struct comm::sockaddr_in)))) + (fli:with-dynamic-lisp-array-pointer (ptr message :type '(:unsigned :byte)) + ;; setup new read timeout + (when read-timeout + (setf old-timeout (get-socket-receive-timeout socket-fd)) + (set-socket-receive-timeout socket-fd read-timeout)) + (mp:with-lock (*message-receive-lock*) + (let ((n (%recvfrom socket-fd ptr max-buffer-size 0 + (fli:copy-pointer client-addr :type '(:struct comm::sockaddr)) + len))) + ;; restore old read timeout + (when (and read-timeout (/= old-timeout read-timeout)) + (set-socket-receive-timeout socket-fd old-timeout)) + (if (plusp n) + (values (if buffer + (replace buffer message + :end1 (min length max-buffer-size) + :end2 (min n max-buffer-size)) + (subseq message 0 (min n max-buffer-size))) + (min n max-buffer-size) + (comm::ntohl (fli:foreign-slot-value + (fli:foreign-slot-value client-addr + 'comm::sin_addr + :object-type '(:struct comm::sockaddr_in) + :type '(:struct comm::in_addr) + :copy-foreign-object nil) + 'comm::s_addr + :object-type '(:struct comm::in_addr))) + (comm::ntohs (fli:foreign-slot-value client-addr + 'comm::sin_port + :object-type '(:struct comm::sockaddr_in) + :type '(:unsigned :short) + :copy-foreign-object nil))) + (values nil n 0 0)))))))) + +(defmethod socket-receive ((socket datagram-usocket) buffer length &key) + (let ((s (socket socket))) + (multiple-value-bind (buffer size host port) + (receive-message s buffer length) + (values buffer size host port)))) + (defmethod get-local-name ((usocket usocket)) (multiple-value-bind (address port) Modified: usocket/trunk/backend/openmcl.lisp ============================================================================== --- usocket/trunk/backend/openmcl.lisp (original) +++ usocket/trunk/backend/openmcl.lisp Thu Jan 7 13:26:06 2010 @@ -74,20 +74,35 @@ :text :binary)) -(defun socket-connect (host port &key (element-type 'character) timeout deadline nodelay +(defun socket-connect (host port &key (protocol :stream) (element-type 'character) + timeout deadline nodelay local-host local-port) (with-mapped-conditions () - (let ((mcl-sock - (openmcl-socket:make-socket :remote-host (host-to-hostname host) - :remote-port port - :local-host (when local-host (host-to-hostname local-host)) - :local-port local-port - :format (to-format element-type) - :deadline deadline - :nodelay nodelay - :connect-timeout timeout))) - (openmcl-socket:socket-connect mcl-sock) - (make-stream-socket :stream mcl-sock :socket mcl-sock)))) + (ecase protocol + (:stream + (let ((mcl-sock + (openmcl-socket:make-socket :remote-host (host-to-hostname host) + :remote-port port + :local-host (when local-host (host-to-hostname local-host)) + :local-port local-port + :format (to-format element-type) + :deadline deadline + :nodelay nodelay + :connect-timeout timeout))) + (openmcl-socket:socket-connect mcl-sock) + (make-stream-socket :stream mcl-sock :socket mcl-sock))) + (:datagram + (let ((mcl-sock + (openmcl-socket:make-socket :address-family :internet + :type :datagram + :local-host (when local-host (host-to-hostname local-host)) + :local-port local-port + :format :binary))) + (when (and host port) + (ccl::inet-connect (ccl::socket-device mcl-sock) + (ccl::host-as-inet-host host) + (ccl::port-as-inet-port port "udp"))) + (make-datagram-socket mcl-sock)))))) (defun socket-listen (host port &key reuseaddress @@ -121,6 +136,16 @@ (with-mapped-conditions (usocket) (close (socket usocket)))) +(defmethod socket-send ((usocket datagram-usocket) buffer length &key host port) + (with-mapped-conditions (usocket) + (openmcl-socket:send-to (socket usocket) buffer length + :remote-host (host-to-hbo host) + :remote-port port))) + +(defmethod socket-receive ((usocket datagram-usocket) buffer length &key) + (with-mapped-conditions (usocket) + (openmcl-socket:receive-from (socket usocket) length :buffer buffer))) + (defmethod get-local-address ((usocket usocket)) (let ((address (openmcl-socket:local-host (socket usocket)))) (when address Modified: usocket/trunk/backend/sbcl.lisp ============================================================================== --- usocket/trunk/backend/sbcl.lisp (original) +++ usocket/trunk/backend/sbcl.lisp Thu Jan 7 13:26:06 2010 @@ -203,8 +203,7 @@ (if usock-cond (signal usock-cond :socket socket)))))) - -(defun socket-connect (host port &key (element-type 'character) +(defun socket-connect (host port &key (protocol :stream) (element-type 'character) timeout deadline (nodelay t nodelay-specified) local-host local-port &aux @@ -221,29 +220,43 @@ (unsupported 'nodelay 'socket-connect)) (let ((socket (make-instance 'sb-bsd-sockets:inet-socket - :type :stream :protocol :tcp))) + :type protocol + :protocol (case protocol + (:stream :tcp) + (:datagram :udp))))) (handler-case - (let* ((stream - (sb-bsd-sockets:socket-make-stream socket - :input t - :output t - :buffering :full - :element-type element-type)) - ;;###FIXME: The above line probably needs an :external-format - (usocket (make-stream-socket :stream stream :socket socket)) - (ip (host-to-vector-quad host))) - ;; binghe: use SOCKOPT-TCP-NODELAY as internal symbol - ;; to pass compilation on ECL without it. - (when (and nodelay-specified sockopt-tcp-nodelay-p) - (setf (sb-bsd-sockets::sockopt-tcp-nodelay socket) nodelay)) - (when (or local-host local-port) - (sb-bsd-sockets:socket-bind socket - (host-to-vector-quad - (or local-host *wildcard-host*)) - (or local-port *auto-port*))) - (with-mapped-conditions (usocket) - (sb-bsd-sockets:socket-connect socket ip port)) - usocket) + (ecase protocol + (:stream + (let* ((stream + (sb-bsd-sockets:socket-make-stream socket + :input t + :output t + :buffering :full + :element-type element-type)) + ;;###FIXME: The above line probably needs an :external-format + (usocket (make-stream-socket :stream stream :socket socket)) + (ip (host-to-vector-quad host))) + ;; binghe: use SOCKOPT-TCP-NODELAY as internal symbol + ;; to pass compilation on ECL without it. + (when (and nodelay-specified sockopt-tcp-nodelay-p) + (setf (sb-bsd-sockets::sockopt-tcp-nodelay socket) nodelay)) + (when (or local-host local-port) + (sb-bsd-sockets:socket-bind socket + (host-to-vector-quad + (or local-host *wildcard-host*)) + (or local-port *auto-port*))) + (with-mapped-conditions (usocket) + (sb-bsd-sockets:socket-connect socket ip port)) + usocket)) + (:datagram + (when (or local-host local-port) + (sb-bsd-sockets:socket-bind socket + (host-to-vector-quad + (or local-host *wildcard-host*)) + (or local-port *auto-port*))) + (when (and host port) + (sb-bsd-sockets:socket-connect socket (host-to-vector-quad host) port)) + (make-datagram-socket socket))) (t (c) ;; Make sure we don't leak filedescriptors (sb-bsd-sockets:socket-close socket) @@ -295,6 +308,18 @@ (with-mapped-conditions (usocket) (close (socket-stream usocket)))) +(defmethod socket-send ((socket datagram-usocket) buffer length &key host port) + (with-mapped-conditions (socket) + (let* ((s (socket socket)) + (dest (if (and host port) (list (host-to-vector-quad host) port) nil))) + (sb-bsd-sockets:socket-send s buffer length :address dest)))) + +(defmethod socket-receive ((socket datagram-usocket) buffer length + &key (element-type '(unsigned-byte 8))) + (with-mapped-conditions (socket) + (let ((s (socket socket))) + (sb-bsd-sockets:socket-receive s buffer length :element-type element-type)))) + (defmethod get-local-name ((usocket usocket)) (sb-bsd-sockets:socket-name (socket usocket))) Modified: usocket/trunk/backend/scl.lisp ============================================================================== --- usocket/trunk/backend/scl.lisp (original) +++ usocket/trunk/backend/scl.lisp Thu Jan 7 13:26:06 2010 @@ -28,7 +28,7 @@ :socket socket :condition condition)))) -(defun socket-connect (host port &key (element-type 'character) +(defun socket-connect (host port &key (protocol :stream) (element-type 'character) timeout deadline (nodelay t nodelay-specified) (local-host nil local-host-p) (local-port nil local-port-p) @@ -43,17 +43,50 @@ (when (and local-port-p (not patch-udp-p)) (unsupported 'local-port 'socket-connect :minimum "1.3.9")) - (let* ((socket (let ((args (list (host-to-hbo host) port :kind :stream))) + (let ((socket)) + (ecase protocol + (:stream + (setf socket (let ((args (list (host-to-hbo host) port :kind protocol))) + (when (and patch-udp-p (or local-host-p local-port-p)) + (nconc args (list :local-host (when local-host + (host-to-hbo local-host)) + :local-port local-port))) + (with-mapped-conditions (socket) + (apply #'ext:connect-to-inet-socket args)))) + (let ((stream (sys:make-fd-stream socket :input t :output t + :element-type element-type + :buffering :full))) + (make-stream-socket :socket socket :stream stream))) + (:datagram + (when (not patch-udp-p) + (error 'unsupported + :feature '(protocol :datagram) + :context 'socket-connect + :minumum "1.3.9")) + (setf socket + (if (and host port) + (let ((args (list (host-to-hbo host) port :kind protocol))) (when (and patch-udp-p (or local-host-p local-port-p)) (nconc args (list :local-host (when local-host (host-to-hbo local-host)) :local-port local-port))) - (with-mapped-conditions () - (apply #'ext:connect-to-inet-socket args)))) - (stream (sys:make-fd-stream socket :input t :output t - :element-type element-type - :buffering :full))) - (make-stream-socket :socket socket :stream stream))) + (with-mapped-conditions (socket) + (apply #'ext:connect-to-inet-socket args))) + (if (or local-host-p local-port-p) + (with-mapped-conditions () + (ext:create-inet-listener (or local-port 0) + protocol + :host (when local-host + (if (ip= local-host *wildcard-host*) + 0 + (host-to-hbo local-host))))) + (with-mapped-conditions () + (ext:create-inet-socket protocol))))) + (let ((usocket (make-datagram-socket socket))) + (ext:finalize usocket #'(lambda () + (when (%open-p usocket) + (ext:close-socket socket)))) + usocket))))) (defun socket-listen (host port &key reuseaddress @@ -99,6 +132,30 @@ (with-mapped-conditions (usocket) (close (socket-stream usocket)))) +(defmethod socket-close :after ((socket datagram-usocket)) + (setf (%open-p socket) nil)) + +(defmethod socket-send ((socket datagram-usocket) buffer length &key host port) + (let ((s (socket socket)) + (host (if host (host-to-hbo host)))) + (multiple-value-bind (result errno) + (ext:inet-socket-send-to s buffer length + :remote-host host :remote-port port) + (or result + (scl-map-socket-error errno :socket socket))))) + +(defmethod socket-receive ((socket datagram-usocket) buffer length &key) + (let ((s (socket socket))) + (let ((real-buffer (or buffer + (make-array length :element-type '(unsigned-byte 8)))) + (real-length (or length + (length buffer)))) + (multiple-value-bind (result errno remote-host remote-port) + (ext:inet-socket-receive-from s real-buffer real-length) + (if result + (values real-buffer result remote-host remote-port) + (scl-map-socket-error errno :socket socket)))))) + (defmethod get-local-name ((usocket usocket)) (multiple-value-bind (address port) (with-mapped-conditions (usocket) Modified: usocket/trunk/package.lisp ============================================================================== --- usocket/trunk/package.lisp (original) +++ usocket/trunk/package.lisp Thu Jan 7 13:26:06 2010 @@ -3,14 +3,20 @@ ;;;; See the LICENSE file for licensing information. -#+lispworks (cl:require "comm") +(in-package :usocket-system) -(cl:eval-when (:execute :load-toplevel :compile-toplevel) - (cl:defpackage :usocket - (:use :cl) - (:export #:*wildcard-host* +#+lispworks +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "comm")) + +(defpackage :usocket + (:use :common-lisp) + (:export #:*wildcard-host* #:*auto-port* + #:*remote-host* ; special variables (udp) + #:*remote-port* + #:socket-connect ; socket constructors and methods #:socket-listen #:socket-accept @@ -22,6 +28,10 @@ #:get-local-name #:get-peer-name + #:socket-send ; udp function (send) + #:socket-receive ; udp function (receive) + #:socket-server ; udp server + #:wait-for-input ; waiting for input-ready state (select() like) #:make-wait-list #:add-waiter @@ -65,9 +75,8 @@ #:ns-unknown-condition #:unknown-error #:ns-unknown-error + #:socket-warning ; warnings (udp) #:insufficient-implementation ; conditions regarding usocket support level #:unsupported - #:unimplemented - ))) - + #:unimplemented)) Modified: usocket/trunk/usocket.asd ============================================================================== --- usocket/trunk/usocket.asd (original) +++ usocket/trunk/usocket.asd Thu Jan 7 13:26:06 2010 @@ -24,10 +24,8 @@ :cl-utilities #+sbcl :sb-bsd-sockets) :components ((:file "package") - (:file "usocket" - :depends-on ("package")) - (:file "condition" - :depends-on ("usocket")) + (:file "usocket" :depends-on ("package")) + (:file "condition" :depends-on ("usocket")) (:module "vendor" :components (#+mcl (:file "kqueue"))) (:module "backend" @@ -40,4 +38,5 @@ #+mcl (:file "mcl") #+openmcl (:file "openmcl") #+allegro (:file "allegro") - #+armedbear (:file "armedbear"))))) + #+armedbear (:file "armedbear"))) + (:file "server" :depends-on ("backend")))) Modified: usocket/trunk/usocket.lisp ============================================================================== --- usocket/trunk/usocket.lisp (original) +++ usocket/trunk/usocket.lisp Thu Jan 7 13:26:06 2010 @@ -11,6 +11,8 @@ (defparameter *auto-port* 0 "Port number to pass when an auto-assigned port number is wanted.") +(defconstant +max-datagram-packet-size+ 65536) + (defclass usocket () ((socket :initarg :socket @@ -83,9 +85,16 @@ be initiated from remote sockets.")) (defclass datagram-usocket (usocket) - ((connected-p :initarg :connected-p :accessor connected-p)) -;; ###FIXME: documentation to be added. - (:documentation "")) + ((connected-p :type boolean + :accessor connected-p + :initarg :connected-p) + #+(or cmu scl lispworks) + (%open-p :type boolean + :accessor %open-p + :initform t + :documentation "Flag to indicate if usocket is open, +for GC on implementions operate on raw socket fd.")) + (:documentation "UDP (inet-datagram) socket")) (defun usocket-p (socket) (typep socket 'usocket)) @@ -151,6 +160,14 @@ (defgeneric socket-close (usocket) (:documentation "Close a previously opened `usocket'.")) +(defgeneric socket-send (usocket buffer length &key host port) + (:documentation "Send packets through a previously opend `usocket'.")) + +(defgeneric socket-receive (usocket buffer length &key) + (:documentation "Receive packets from a previously opend `usocket'. + +Returns 4 values: (values buffer size host port)")) + (defgeneric get-local-address (socket) (:documentation "Returns the IP address of the socket."))

1 0

[usocket-cvs] r514 - usocket/trunk/backend
by Chun Tian 07 Jan '10

07 Jan '10

Author: ctian Date: Thu Jan 7 02:28:38 2010 New Revision: 514 Log: Patch from Terje Norderhaug: an upgrade to the usocket MCL backend that allows a socket server to be shared between multiple processes. It adds a lock so only one process at a time polls for an established connection for the socket. Modified: usocket/trunk/backend/mcl.lisp Modified: usocket/trunk/backend/mcl.lisp ============================================================================== --- usocket/trunk/backend/mcl.lisp (original) +++ usocket/trunk/backend/mcl.lisp Thu Jan 7 02:28:38 2010 @@ -177,8 +177,9 @@ (defclass passive-socket (socket) ((streams :accessor socket-streams :type list :initform NIL - :documentation "Circular list of streams with first element the next to open") - (reuse-address :reader reuse-address :initarg :reuse-address))) + :documentation "Circular list of streams with first element the next to open") + (reuse-address :reader reuse-address :initarg :reuse-address) + (lock :reader socket-lock :initform (ccl:make-lock "Socket")))) (defmethod initialize-instance :after ((socket passive-socket) &key backlog) (loop repeat backlog @@ -191,20 +192,18 @@ #'ccl::stream-local-port (car (socket-streams socket))) (error "timeout"))))) -(defmethod socket-accept ((socket passive-socket) &key element-type) - (flet ((connection-established-p (stream) - (ccl::with-io-buffer-locked ((ccl::stream-io-buffer stream nil)) - (let ((state (ccl::opentransport-stream-connection-state stream))) - (not (eq :unbnd state)))))) +(defmethod socket-accept ((socket passive-socket) &key element-type &aux (lock (socket-lock socket))) + (flet ((connection-established-p (stream) + (ccl::with-io-buffer-locked ((ccl::stream-io-buffer stream nil)) + (let ((state (ccl::opentransport-stream-connection-state stream))) + (not (eq :unbnd state)))))) (with-mapped-conditions () - (let* ((new (socket-open-listener socket element-type)) - (connection (car (socket-streams socket)))) - (assert connection) - (rplaca (socket-streams socket) new) - (setf (socket-streams socket) - (cdr (socket-streams socket))) - (ccl::process-wait "Socket Accept" #'connection-established-p connection) ; expensive polling... - connection)))) + (ccl:with-lock-grabbed (lock nil "Socket Lock") + (let ((connection (shiftf (car (socket-streams socket)) + (socket-open-listener socket element-type)))) + (pop (socket-streams socket)) + (ccl:process-wait "Accepting" #'connection-established-p connection) + connection))))) (defmethod socket-close ((socket passive-socket)) (loop

1 0

[usocket-cvs] r513 - usocket/trunk/backend
by Chun Tian 06 Jan '10

06 Jan '10

Author: ctian Date: Tue Jan 5 20:23:50 2010 New Revision: 513 Log: Include MCL Issue 28. Modified: usocket/trunk/backend/mcl.lisp Modified: usocket/trunk/backend/mcl.lisp ============================================================================== --- usocket/trunk/backend/mcl.lisp (original) +++ usocket/trunk/backend/mcl.lisp Tue Jan 5 20:23:50 2010 @@ -6,35 +6,45 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (require :opentransport)) +;; MCL Issue 28: Passive TCP streams should be able to listen to the loopback interface +;; see http://code.google.com/p/mcl/issues/detail?id=28 for details + +(defparameter *passive-interface-address* NIL + "Address to use for passive connections - optionally bind to loopback address while opening a tcp stream") + +(advise local-interface-ip-address + (or *passive-interface-address* (:do-it)) + :when :around :name 'override-local-interface-ip-address) + ;; 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) +(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)

1 0

[usocket-cvs] r512 - in usocket/trunk: backend vendor
by Chun Tian 04 Jan '10

04 Jan '10

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(a)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(a)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(a)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(a)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 ,@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(a)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(a)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(a)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 ,@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

1 0

[usocket-cvs] r511 - in usocket/trunk: . backend doc notes test vendor
by Chun Tian 04 Jan '10

04 Jan '10

Author: ctian Date: Mon Jan 4 03:06:20 2010 New Revision: 511 Log: Update ignore patterns Modified: usocket/trunk/ (props changed) usocket/trunk/backend/ (props changed) usocket/trunk/doc/ (props changed) usocket/trunk/notes/ (props changed) usocket/trunk/test/ (props changed) usocket/trunk/vendor/ (props changed)

1 0