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

[usocket-cvs] r510 - in usocket/trunk: . backend test
by Chun Tian 04 Jan '10

04 Jan '10

Author: ctian Date: Mon Jan 4 02:49:39 2010 New Revision: 510 Log: MCL and usocket-test fixes from James Anderson <james.anderson(a)setf.de> Added: usocket/trunk/usocket-test.asd Removed: usocket/trunk/test/usocket-test.asd Modified: usocket/trunk/backend/mcl.lisp usocket/trunk/test/test-usocket.lisp usocket/trunk/usocket.asd Modified: usocket/trunk/backend/mcl.lisp ============================================================================== --- usocket/trunk/backend/mcl.lisp (original) +++ usocket/trunk/backend/mcl.lisp Mon Jan 4 02:49:39 2010 @@ -9,7 +9,9 @@ (defun handle-condition (condition &optional socket) ; incomplete, needs to handle additional conditions (flet ((raise-error (&optional socket-condition) - (error (or socket-condition 'unknown-error) :socket socket :real-error condition))) + (if socket-condition + (error socket-condition :socket socket) + (error 'unknown-error :socket socket :real-error condition)))) (typecase condition (ccl:host-stopped-responding (raise-error 'host-down-error)) @@ -20,24 +22,25 @@ (ccl:connection-timed-out (raise-error 'timeout-error)) (ccl:opentransport-protocol-error - (raise-error ''protocol-not-supported-error)) + (raise-error 'protocol-not-supported-error)) (otherwise (raise-error))))) (defun socket-connect (host port &key (element-type 'character) timeout deadline nodelay local-host local-port) - (let* ((socket - (make-instance 'active-socket - :remote-host (when host (host-to-hostname host)) - :remote-port port - :local-host (when local-host (host-to-hostname local-host)) - :local-port local-port - :deadline deadline - :nodelay nodelay - :connect-timeout (and timeout (round (* timeout 60))) - :element-type element-type)) - (stream (socket-open-stream socket))) - (make-stream-socket :socket socket :stream stream))) + (with-mapped-conditions () + (let* ((socket + (make-instance 'active-socket + :remote-host (when host (host-to-hostname host)) + :remote-port port + :local-host (when local-host (host-to-hostname local-host)) + :local-port local-port + :deadline deadline + :nodelay nodelay + :connect-timeout (and timeout (round (* timeout 60))) + :element-type element-type)) + (stream (socket-open-stream socket))) + (make-stream-socket :socket socket :stream stream)))) (defun socket-listen (host port &key reuseaddress @@ -45,16 +48,18 @@ (backlog 5) (element-type 'character)) (declare (ignore reuseaddress reuse-address-supplied-p)) - (let ((socket (make-instance 'passive-socket - :local-port port - :local-host host - :reuse-address reuse-address - :backlog backlog))) + (let ((socket (with-mapped-conditions () + (make-instance 'passive-socket + :local-port port + :local-host host + :reuse-address reuse-address + :backlog backlog)))) (make-stream-server-socket socket :element-type element-type))) (defmethod socket-accept ((usocket stream-server-usocket) &key element-type) (let* ((socket (socket usocket)) - (stream (socket-accept socket :element-type element-type))) + (stream (with-mapped-conditions (usocket) + (socket-accept socket :element-type element-type)))) (make-stream-socket :socket socket :stream stream))) (defmethod socket-close ((usocket usocket)) @@ -93,6 +98,17 @@ (defmethod get-peer-port ((usocket stream-usocket)) (remote-port (socket usocket))) + +(defun %setup-wait-list (wait-list) + (declare (ignore wait-list))) + +(defun %add-waiter (wait-list waiter) + (declare (ignore wait-list waiter))) + +(defun %remove-waiter (wait-list waiter) + (declare (ignore wait-list waiter))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; BASIC MCL SOCKET IMPLEMENTATION Modified: usocket/trunk/test/test-usocket.lisp ============================================================================== --- usocket/trunk/test/test-usocket.lisp (original) +++ usocket/trunk/test/test-usocket.lisp Mon Jan 4 02:49:39 2010 @@ -7,12 +7,15 @@ ;; The parameters below may need adjustments to match the system ;; the tests are run on. -(defparameter +non-existing-host+ "192.168.1.1") +(defparameter +non-existing-host+ "192.168.1.199") (defparameter +unused-local-port+ 15213) (defparameter *soc1* (usocket::make-stream-socket :socket :my-socket :stream :my-stream)) (eval-when (:compile-toplevel :load-toplevel :execute) - (defparameter +common-lisp-net+ #(80 68 86 115))) ;; common-lisp.net IP + (defparameter +local-ip+ #(192 168 1 25)) + (defparameter +common-lisp-net+ + #+ignore #(80 68 86 115) ;; common-lisp.net IP (not valid as of 2010-01-03 + (first (usocket::get-hosts-by-name "common-lisp.net")))) (defmacro with-caught-conditions ((expect throw) &body body) `(catch 'caught-error @@ -48,29 +51,29 @@ (deftest socket-no-connect.1 (with-caught-conditions ('usocket:socket-error nil) - (usocket:socket-connect "127.0.0.0" +unused-local-port+) + (usocket:socket-connect "127.0.0.0" +unused-local-port+ :timeout 0) t) nil) (deftest socket-no-connect.2 (with-caught-conditions ('usocket:socket-error nil) - (usocket:socket-connect #(127 0 0 0) +unused-local-port+) + (usocket:socket-connect #(127 0 0 0) +unused-local-port+ :timeout 0) t) nil) (deftest socket-no-connect.3 (with-caught-conditions ('usocket:socket-error nil) - (usocket:socket-connect 2130706432 +unused-local-port+) ;; == #(127 0 0 0) + (usocket:socket-connect 2130706432 +unused-local-port+ :timeout 0) ;; == #(127 0 0 0) t) nil) (deftest socket-failure.1 - (with-caught-conditions (#-(or cmu lispworks armedbear openmcl) + (with-caught-conditions (#-(or cmu lispworks armedbear openmcl mcl) 'usocket:network-unreachable-error #+(or cmu lispworks armedbear) 'usocket:unknown-error - #+openmcl + #+(or openmcl mcl) 'usocket:timeout-error nil) - (usocket:socket-connect 2130706432 +unused-local-port+) ;; == #(127 0 0 0) + (usocket:socket-connect 2130706432 +unused-local-port+ :timeout 0) ;; == #(127 0 0 0) :unreach) nil) (deftest socket-failure.2 @@ -78,12 +81,12 @@ 'usocket:unknown-error #+cmu 'usocket:network-unreachable-error - #+openmcl + #+(or openmcl mcl) 'usocket:timeout-error - #-(or lispworks armedbear cmu openmcl) + #-(or lispworks armedbear cmu openmcl mcl) 'usocket:host-unreachable-error nil) - (usocket:socket-connect +non-existing-host+ 80) ;; 80 = just a port + (usocket:socket-connect +non-existing-host+ 80 :timeout 0) ;; 80 = just a port :unreach) nil) @@ -94,21 +97,21 @@ (with-caught-conditions (nil nil) (let ((sock (usocket:socket-connect "common-lisp.net" 80))) (unwind-protect - (typep sock 'usocket:usocket) + (when (typep sock 'usocket:usocket) t) (usocket:socket-close sock)))) t) (deftest socket-connect.2 (with-caught-conditions (nil nil) (let ((sock (usocket:socket-connect +common-lisp-net+ 80))) (unwind-protect - (typep sock 'usocket:usocket) + (when (typep sock 'usocket:usocket) t) (usocket:socket-close sock)))) t) (deftest socket-connect.3 (with-caught-conditions (nil nil) (let ((sock (usocket:socket-connect (usocket::host-byte-order +common-lisp-net+) 80))) (unwind-protect - (typep sock 'usocket:usocket) + (when (typep sock 'usocket:usocket) t) (usocket:socket-close sock)))) t) @@ -119,13 +122,13 @@ (unwind-protect (progn (format (usocket:socket-stream sock) - "GET / HTTP/1.0~A~A~A~A" - #\Return #\Newline #\Return #\Newline) + "GET / HTTP/1.0~c~c~c~c" + #\Return #\linefeed #\Return #\linefeed) (force-output (usocket:socket-stream sock)) (read-line (usocket:socket-stream sock))) (usocket:socket-close sock)))) - #+clisp "HTTP/1.1 200 OK" - #-clisp #.(format nil "HTTP/1.1 200 OK~A" #\Return) nil) + #+(or mcl clisp) "HTTP/1.1 200 OK" + #-(or clisp mcl) #.(format nil "HTTP/1.1 200 OK~A" #\Return) nil) (deftest socket-name.1 (with-caught-conditions (nil nil) @@ -154,8 +157,10 @@ (unwind-protect (usocket::get-local-address sock) (usocket:socket-close sock)))) - #(192 168 1 65)) + #.+local-ip+) (defun run-usocket-tests () (do-tests)) + +;;; (usoct::run-usocket-tests ) \ No newline at end of file Added: usocket/trunk/usocket-test.asd ============================================================================== --- (empty file) +++ usocket/trunk/usocket-test.asd Mon Jan 4 02:49:39 2010 @@ -0,0 +1,26 @@ +;;;; -*- Mode: Lisp -*- +;;;; $Id: usocket-test.asd 46 2006-02-06 20:50:07Z ehuelsmann $ +;;;; $URL: svn+ssh://common-lisp.net/project/usocket/svn/usocket/trunk/test/usocket-te… $ + +;;;; See the LICENSE file for licensing information. + +(in-package :cl-user) + +(unless (find-package ':usocket-system) + (make-package ':usocket-system + :use '(:cl :asdf))) + +(in-package :usocket-system) + +(defsystem usocket-test + :name "usocket test" + :author "Erik Enge" + :version "0.1.0" + :licence "MIT" + :description "Tests for usocket" + :depends-on (:usocket + :rt) + :components ((:module "test" + :components ((:file "package") + (:file "test-usocket" + :depends-on ("package")))))) Modified: usocket/trunk/usocket.asd ============================================================================== --- usocket/trunk/usocket.asd (original) +++ usocket/trunk/usocket.asd Mon Jan 4 02:49:39 2010 @@ -1,4 +1,4 @@ - +;;;; -*- Mode: Lisp -*- ;;;; $Id$ ;;;; $URL$ @@ -11,13 +11,17 @@ (in-package #:usocket-system) +(pushnew :split-sequence-deprecated *features*) + (defsystem usocket :name "usocket" :author "Erik Enge & Erik Huelsmann" - :version "0.5.0-dev" + :version "0.5.0" :licence "MIT" :description "Universal socket library for Common Lisp" - :depends-on (:split-sequence + :depends-on (;; :split-sequence + ;; use the splie-sequence from cl-utilities + :cl-utilities #+sbcl :sb-bsd-sockets) :components ((:file "package") (:file "usocket" @@ -25,15 +29,15 @@ (:file "condition" :depends-on ("usocket")) (:module "vendor" - :components (#+mcl (:file "kqueue"))) + :components (#+mcl (:file "kqueue"))) (:module "backend" - :depends-on ("condition" "vendor") - :components (#+clisp (:file "clisp") - #+cmu (:file "cmucl") - #+scl (:file "scl") - #+(or sbcl ecl) (:file "sbcl") - #+lispworks (:file "lispworks") - #+mcl (:file "mcl") - #+openmcl (:file "openmcl") - #+allegro (:file "allegro") - #+armedbear (:file "armedbear"))))) + :depends-on ("condition" "vendor") + :components (#+clisp (:file "clisp") + #+cmu (:file "cmucl") + #+scl (:file "scl") + #+(or sbcl ecl) (:file "sbcl") + #+lispworks (:file "lispworks") + #+mcl (:file "mcl") + #+openmcl (:file "openmcl") + #+allegro (:file "allegro") + #+armedbear (:file "armedbear")))))

1 0

[usocket-cvs] r509 - usocket/trunk/backend
by Chun Tian 04 Jan '10

04 Jan '10

Author: ctian Date: Mon Jan 4 02:20:24 2010 New Revision: 509 Log: OpenMCL bugfix: socket-connect scales the timeout value incorrectly, thanks to James Anderson <james.anderson(a)setf.de> Modified: usocket/trunk/backend/openmcl.lisp Modified: usocket/trunk/backend/openmcl.lisp ============================================================================== --- usocket/trunk/backend/openmcl.lisp (original) +++ usocket/trunk/backend/openmcl.lisp Mon Jan 4 02:20:24 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] r508 - in usocket/trunk: . backend doc vendor
by Chun Tian 04 Jan '10

04 Jan '10

Author: ctian Date: Mon Jan 4 02:16:10 2010 New Revision: 508 Log: Initial import of MCL's wait-for-input implementation, submit by Terje Norderhaug Added: usocket/trunk/vendor/ usocket/trunk/vendor/kqueue.lisp (contents, props changed) Modified: usocket/trunk/backend/mcl.lisp usocket/trunk/doc/backends.txt usocket/trunk/usocket.asd Modified: usocket/trunk/backend/mcl.lisp ============================================================================== --- usocket/trunk/backend/mcl.lisp (original) +++ usocket/trunk/backend/mcl.lisp Mon Jan 4 02:16:10 2010 @@ -168,6 +168,59 @@ (declare (special ccl::*passive-interface-address*)) new)) + +(defun wait-for-input-internal (wait-list &key timeout &aux result) + (macrolet ((when-io-buffer-lock-grabbed ((lock &optional multiple-value-p) &body body) + "Evaluates the body if and only if the lock is successfully grabbed" + ;; like with-io-buffer-lock-grabbed but returns immediately instead of polling the lock + (let ((needs-unlocking-p (gensym)) + (lock-var (gensym))) + `(let* ((,lock-var ,lock) + (ccl::*grabbed-io-buffer-locks* (cons ,lock-var ccl::*grabbed-io-buffer-locks*)) + (,needs-unlocking-p (needs-unlocking-p ,lock-var))) + (declare (dynamic-extent ccl::*grabbed-io-buffer-locks*)) + (when ,needs-unlocking-p + (,(if multiple-value-p 'multiple-value-prog1 'prog1) + (progn ,@body) + (ccl::%release-io-buffer-lock ,lock-var))))))) + (labels ((needs-unlocking-p (lock) + (declare (type ccl::lock lock)) + ;; crucial - clears bogus lock.value as in grab-io-buffer-lock-out-of-line: + (ccl::%io-buffer-lock-really-grabbed-p lock) + (ccl:store-conditional lock nil ccl:*current-process*)) + (input-available (stream) + "similar to stream-listen on buffered-input-stream-mixin but without waiting for lock" + (let ((io-buffer (ccl::stream-io-buffer stream))) + (or (not (eql 0 (ccl::io-buffer-incount io-buffer))) + (ccl::io-buffer-untyi-char io-buffer) + (locally (declare (optimize (speed 3) (safety 0))) + (when-io-buffer-lock-grabbed ((ccl::io-buffer-lock io-buffer)) + (funcall (ccl::io-buffer-listen-function io-buffer) stream io-buffer)))))) + (ready-sockets (sockets) + (dolist (sock sockets result) + (when (input-available (socket-stream sock)) + (push sock result))))) + (with-mapped-conditions () + (ccl:process-wait-with-timeout + "socket input" + (when timeout (truncate (* timeout 60))) + #'ready-sockets + (wait-list-waiters wait-list))) + (nreverse result)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +#| Test for wait-for-input +(let* ((sock1 (usocket:socket-connect "in-progress.com" 80)) + (sock2 (usocket:socket-connect "common-lisp.net" 80)) + (sockets (list sock1 sock2))) + (dolist (sock sockets) + (format (usocket:socket-stream sock) + "GET / HTTP/1.0~A~A~A~A" + #\Return #\Linefeed #\Return #\Linefeed) + (force-output (usocket:socket-stream sock))) + (wait-for-input sockets :timeout 5000)) +|# + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #| TEST (from test-usocket.lisp) Modified: usocket/trunk/doc/backends.txt ============================================================================== --- usocket/trunk/doc/backends.txt (original) +++ usocket/trunk/doc/backends.txt Mon Jan 4 02:16:10 2010 @@ -15,6 +15,7 @@ - get-hosts-by-name [ optional ] - get-host-by-address [ optional ] + - wait-for-input-internal (new in 0.4.x) Methods: Modified: usocket/trunk/usocket.asd ============================================================================== --- usocket/trunk/usocket.asd (original) +++ usocket/trunk/usocket.asd Mon Jan 4 02:16:10 2010 @@ -24,8 +24,10 @@ :depends-on ("package")) (:file "condition" :depends-on ("usocket")) + (:module "vendor" + :components (#+mcl (:file "kqueue"))) (:module "backend" - :depends-on ("condition") + :depends-on ("condition" "vendor") :components (#+clisp (:file "clisp") #+cmu (:file "cmucl") #+scl (:file "scl") Added: usocket/trunk/vendor/kqueue.lisp ============================================================================== --- (empty file) +++ usocket/trunk/vendor/kqueue.lisp Mon Jan 4 02:16:10 2010 @@ -0,0 +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

1 0

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

03 Jan '10

Author: ctian Date: Sun Jan 3 03:54:58 2010 New Revision: 507 Log: ASDF system definition changes for MCL, also make it smaller Modified: usocket/trunk/backend/mcl.lisp usocket/trunk/usocket.asd Modified: usocket/trunk/backend/mcl.lisp ============================================================================== --- usocket/trunk/backend/mcl.lisp (original) +++ usocket/trunk/backend/mcl.lisp Sun Jan 3 03:54:58 2010 @@ -3,6 +3,9 @@ (in-package :usocket) +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :opentransport)) + (defun handle-condition (condition &optional socket) ; incomplete, needs to handle additional conditions (flet ((raise-error (&optional socket-condition) @@ -93,8 +96,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; BASIC MCL SOCKET IMPLEMENTATION -(require :opentransport) - (defclass socket () ((local-port :reader local-port :initarg :local-port) (local-host :reader local-host :initarg :local-host) Modified: usocket/trunk/usocket.asd ============================================================================== --- usocket/trunk/usocket.asd (original) +++ usocket/trunk/usocket.asd Sun Jan 3 03:54:58 2010 @@ -24,22 +24,14 @@ :depends-on ("package")) (:file "condition" :depends-on ("usocket")) - #+clisp (:file "clisp" :pathname "backend/clisp" - :depends-on ("condition")) - #+cmu (:file "cmucl" :pathname "backend/cmucl" - :depends-on ("condition")) - #+scl (:file "scl" :pathname "backend/scl" - :depends-on ("condition")) - #+(or sbcl ecl) (:file "sbcl" :pathname "backend/sbcl" - :depends-on ("condition")) - #+lispworks (:file "lispworks" :pathname "backend/lispworks" - :depends-on ("condition")) - #+openmcl (:file "openmcl" :pathname "backend/openmcl" - :depends-on ("condition")) - #+allegro (:file "allegro" :pathname "backend/allegro" - :depends-on ("condition")) - #+armedbear (:file "armedbear" :pathname "backend/armedbear" - :depends-on ("condition")) - #+mcl (:file "mcl" :pathname "backend/armedbear" - :depends-on ("condition")) - )) + (:module "backend" + :depends-on ("condition") + :components (#+clisp (:file "clisp") + #+cmu (:file "cmucl") + #+scl (:file "scl") + #+(or sbcl ecl) (:file "sbcl") + #+lispworks (:file "lispworks") + #+mcl (:file "mcl") + #+openmcl (:file "openmcl") + #+allegro (:file "allegro") + #+armedbear (:file "armedbear")))))

1 0

[usocket-cvs] r506 - usocket/trunk
by Chun Tian 03 Jan '10

03 Jan '10

Author: ctian Date: Sun Jan 3 02:37:22 2010 New Revision: 506 Log: Add MCL support into usocket.asd Modified: usocket/trunk/usocket.asd Modified: usocket/trunk/usocket.asd ============================================================================== --- usocket/trunk/usocket.asd (original) +++ usocket/trunk/usocket.asd Sun Jan 3 02:37:22 2010 @@ -40,4 +40,6 @@ :depends-on ("condition")) #+armedbear (:file "armedbear" :pathname "backend/armedbear" :depends-on ("condition")) + #+mcl (:file "mcl" :pathname "backend/armedbear" + :depends-on ("condition")) ))

1 0

[usocket-cvs] r505 - usocket/trunk/backend
by Chun Tian 03 Jan '10

03 Jan '10

Author: ctian Date: Sun Jan 3 02:29:07 2010 New Revision: 505 Log: Initial MCL backend support from Terje Norderhaug Added: usocket/trunk/backend/mcl.lisp (contents, props changed) Added: usocket/trunk/backend/mcl.lisp ============================================================================== --- (empty file) +++ usocket/trunk/backend/mcl.lisp Sun Jan 3 02:29:07 2010 @@ -0,0 +1,258 @@ +;; MCL backend for USOCKET 0.4.1 +;; Terje Norderhaug <terje(a)in-progress.com>, January 1, 2009 + +(in-package :usocket) + +(defun handle-condition (condition &optional socket) + ; incomplete, needs to handle additional conditions + (flet ((raise-error (&optional socket-condition) + (error (or socket-condition 'unknown-error) :socket socket :real-error condition))) + (typecase condition + (ccl:host-stopped-responding + (raise-error 'host-down-error)) + (ccl:host-not-responding + (raise-error 'host-unreachable-error)) + (ccl:connection-reset + (raise-error 'connection-reset-error)) + (ccl:connection-timed-out + (raise-error 'timeout-error)) + (ccl:opentransport-protocol-error + (raise-error ''protocol-not-supported-error)) + (otherwise + (raise-error))))) + +(defun socket-connect (host port &key (element-type 'character) timeout deadline nodelay + local-host local-port) + (let* ((socket + (make-instance 'active-socket + :remote-host (when host (host-to-hostname host)) + :remote-port port + :local-host (when local-host (host-to-hostname local-host)) + :local-port local-port + :deadline deadline + :nodelay nodelay + :connect-timeout (and timeout (round (* timeout 60))) + :element-type element-type)) + (stream (socket-open-stream socket))) + (make-stream-socket :socket socket :stream stream))) + +(defun socket-listen (host port + &key reuseaddress + (reuse-address nil reuse-address-supplied-p) + (backlog 5) + (element-type 'character)) + (declare (ignore reuseaddress reuse-address-supplied-p)) + (let ((socket (make-instance 'passive-socket + :local-port port + :local-host host + :reuse-address reuse-address + :backlog backlog))) + (make-stream-server-socket socket :element-type element-type))) + +(defmethod socket-accept ((usocket stream-server-usocket) &key element-type) + (let* ((socket (socket usocket)) + (stream (socket-accept socket :element-type element-type))) + (make-stream-socket :socket socket :stream stream))) + +(defmethod socket-close ((usocket usocket)) + (with-mapped-conditions (usocket) + (socket-close (socket usocket)))) + +(defmethod ccl::stream-close ((usocket usocket)) + (socket-close usocket)) + +(defun get-hosts-by-name (name) + (with-mapped-conditions () + (list (hbo-to-vector-quad (ccl::get-host-address + (host-to-hostname name)))))) + +(defun get-host-by-address (address) + (with-mapped-conditions () + (ccl::inet-host-name (host-to-hbo address)))) + +(defmethod get-local-name ((usocket usocket)) + (values (get-local-address usocket) + (get-local-port usocket))) + +(defmethod get-peer-name ((usocket stream-usocket)) + (values (get-peer-address usocket) + (get-peer-port usocket))) + +(defmethod get-local-address ((usocket usocket)) + (hbo-to-vector-quad (ccl::get-host-address (or (local-host (socket usocket)) "")))) + +(defmethod get-local-port ((usocket usocket)) + (local-port (socket usocket))) + +(defmethod get-peer-address ((usocket stream-usocket)) + (hbo-to-vector-quad (ccl::get-host-address (remote-host (socket usocket))))) + +(defmethod get-peer-port ((usocket stream-usocket)) + (remote-port (socket usocket))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; BASIC MCL SOCKET IMPLEMENTATION + +(require :opentransport) + +(defclass socket () + ((local-port :reader local-port :initarg :local-port) + (local-host :reader local-host :initarg :local-host) + (element-type :reader element-type :initform 'ccl::base-character :initarg :element-type))) + +(defclass active-socket (socket) + ((remote-host :reader remote-host :initarg :remote-host) + (remote-port :reader remote-port :initarg :remote-port) + (deadline :initarg :deadline) + (nodelay :initarg :nodelay) + (connect-timeout :reader connect-timeout :initform NIL :initarg :connect-timeout + :type (or null fixnum) :documentation "ticks (60th of a second)"))) + +(defmethod socket-open-stream ((socket active-socket)) + (ccl::open-tcp-stream (or (remote-host socket)(ccl::local-interface-ip-address)) (remote-port socket) + :element-type (if (subtypep (element-type socket) 'character) 'ccl::base-character 'unsigned-byte) + :connect-timeout (connect-timeout socket))) + +(defmethod socket-close ((socket active-socket)) + NIL) + +(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))) + +(defmethod initialize-instance :after ((socket passive-socket) &key backlog) + (loop repeat backlog + collect (socket-open-listener socket) into streams + finally (setf (socket-streams socket) + (cdr (rplacd (last streams) streams)))) + (when (zerop (local-port socket)) + (setf (slot-value socket 'local-port) + (or (ccl::process-wait-with-timeout "binding port" (* 10 60) + #'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)))))) + (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)))) + +(defmethod socket-close ((socket passive-socket)) + (loop + with streams = (socket-streams socket) + for (stream tail) on streams + do (close stream :abort T) + until (eq tail streams) + finally (setf (socket-streams socket) NIL))) + +(defmethod socket-open-listener (socket &optional element-type) + ; see http://code.google.com/p/mcl/issues/detail?id=28 + (let* ((ccl::*passive-interface-address* (local-host socket)) + (new (ccl::open-tcp-stream NIL (or (local-port socket) #$kOTAnyInetAddress) + :reuse-local-port-p (reuse-address socket) + :element-type (if (subtypep (or element-type (element-type socket)) + 'character) + 'ccl::base-character + 'unsigned-byte)))) + (declare (special ccl::*passive-interface-address*)) + new)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +#| TEST (from test-usocket.lisp) + + +(defparameter +non-existing-host+ "192.168.1.1") +(defparameter +unused-local-port+ 15213) +(defparameter *soc1* (usocket::make-stream-socket :socket :my-socket + :stream :my-stream)) +(defparameter +common-lisp-net+ #(208 72 159 207)) ;; common-lisp.net IP + + +(usocket:socket *soc1*) + +(usocket:socket-connect "127.0.0.0" +unused-local-port+) + +(usocket:socket-connect #(127 0 0 0) +unused-local-port+) + +(usocket:socket-connect 2130706432 +unused-local-port+) + + (let ((sock (usocket:socket-connect "common-lisp.net" 80))) + (unwind-protect + (typep sock 'usocket:usocket) + (usocket:socket-close sock))) + + (let ((sock (usocket:socket-connect +common-lisp-net+ 80))) + (unwind-protect + (typep sock 'usocket:usocket) + (usocket:socket-close sock))) + + (let ((sock (usocket:socket-connect (usocket::host-byte-order +common-lisp-net+) 80))) + (unwind-protect + (typep sock 'usocket:usocket) + (usocket:socket-close sock))) + +(let ((sock (usocket:socket-connect "common-lisp.net" 80))) + (unwind-protect + (progn + (format (usocket:socket-stream sock) + "GET / HTTP/1.0~A~A~A~A" + #\Return #\Linefeed #\Return #\Linefeed) + (force-output (usocket:socket-stream sock)) + (read-line (usocket:socket-stream sock))) + (usocket:socket-close sock))) + + (let ((sock (usocket:socket-connect +common-lisp-net+ 80))) + (unwind-protect + (usocket::get-peer-address sock) + (usocket:socket-close sock))) + + (let ((sock (usocket:socket-connect +common-lisp-net+ 80))) + (unwind-protect + (usocket::get-peer-port sock) + (usocket:socket-close sock))) + + (let ((sock (usocket:socket-connect +common-lisp-net+ 80))) + (unwind-protect + (usocket::get-peer-name sock) + (usocket:socket-close sock))) + + (let ((sock (usocket:socket-connect +common-lisp-net+ 80))) + (unwind-protect + (usocket::get-local-address sock) + (usocket:socket-close sock))) + +|# + + +#| + +(defun socket-server (host port) + (let ((socket (socket-listen host port))) + (unwind-protect + (loop + (with-open-stream (stream (socket-stream (socket-accept socket))) + (ccl::telnet-write-line stream "~A" + (reverse (ccl::telnet-read-line stream))) + (ccl::force-output stream))) + (close socket)))) + +(ccl::process-run-function "Socket Server" #'socket-server NIL 4088) + +(let* ((sock (socket-connect nil 4088)) + (stream (usocket:socket-stream sock))) + (assert (streamp stream)) + (ccl::telnet-write-line stream "hello ~A" (random 10)) + (ccl::force-output stream) + (ccl::telnet-read-line stream)) + +|#

1 0