[usocket-cvs] r542 - in usocket/trunk: . backend vendor
Chun Tian (binghe)
ctian at common-lisp.net
Mon Jul 12 09:47:40 UTC 2010
Author: ctian
Date: Mon Jul 12 05:47:40 2010
New Revision: 542
Log:
Server: improved SOCKET-SERVER, for both TCP and UDP now.
Added:
usocket/trunk/vendor/spawn-thread.lisp (contents, props changed)
Modified:
usocket/trunk/backend/lispworks.lisp
usocket/trunk/package.lisp
usocket/trunk/server.lisp
usocket/trunk/usocket.asd
Modified: usocket/trunk/backend/lispworks.lisp
==============================================================================
--- usocket/trunk/backend/lispworks.lisp (original)
+++ usocket/trunk/backend/lispworks.lisp Mon Jul 12 05:47:40 2010
@@ -298,10 +298,10 @@
(:datagram
(let ((usocket (make-datagram-socket
(if (and host port)
- (connect-to-udp-server host port
- :local-address local-host
+ (connect-to-udp-server (host-to-hostname host) port
+ :local-address (and local-host (host-to-hostname local-host))
:local-port local-port)
- (open-udp-socket :local-address local-host
+ (open-udp-socket :local-address (and local-host (host-to-hostname local-host))
:local-port local-port))
:connected-p t)))
(hcl:flag-special-free-action usocket)
Modified: usocket/trunk/package.lisp
==============================================================================
--- usocket/trunk/package.lisp (original)
+++ usocket/trunk/package.lisp Mon Jul 12 05:47:40 2010
@@ -80,3 +80,19 @@
#:insufficient-implementation ; conditions regarding usocket support level
#:unsupported
#:unimplemented))
+
+(in-package :usocket)
+
+;;; Logical Pathname Translations, learn from CL-HTTP source code
+(eval-when (:load-toplevel :execute)
+ (let* ((defaults #+asdf (asdf:component-pathname (asdf:find-system :usocket))
+ #-asdf *load-truename*)
+ (home (make-pathname :name :wild :type :wild
+ :directory (append (pathname-directory defaults)
+ '(:wild-inferiors))
+ :host (pathname-host defaults)
+ :defaults defaults
+ :version :newest)))
+ (setf (logical-pathname-translations "usocket")
+ `(("**;*.*.newest" ,home)
+ ("**;*.*" ,home)))))
Modified: usocket/trunk/server.lisp
==============================================================================
--- usocket/trunk/server.lisp (original)
+++ usocket/trunk/server.lisp Mon Jul 12 05:47:40 2010
@@ -3,43 +3,96 @@
(in-package :usocket)
+(defun socket-server (host port function &optional arguments
+ &key in-new-thread (protocol :stream)
+ ;; for udp
+ (timeout 1) (max-buffer-size +max-datagram-packet-size+)
+ ;; for tcp
+ element-type reuse-address multi-threading)
+ (let* ((real-host (or host #(0 0 0 0)))
+ (socket (ecase protocol
+ (:stream
+ (apply #'socket-listen
+ `(,real-host ,port
+ ,@(when element-type `(:element-type ,element-type))
+ ,@(when reuse-address `(:reuse-address ,reuse-address)))))
+ (:datagram
+ (socket-connect nil nil :protocol :datagram
+ :local-host real-host
+ :local-port port)))))
+ (labels ((real-call ()
+ (ecase protocol
+ (:stream
+ (tcp-event-loop socket function arguments
+ :element-type element-type
+ :multi-threading multi-threading))
+ (:datagram
+ (udp-event-loop socket function arguments
+ :timeout timeout
+ :max-buffer-size max-buffer-size)))))
+ (if in-new-thread
+ (spawn-thread "USOCKET Server" #'real-call)
+ (real-call)))))
+
(defvar *remote-host*)
(defvar *remote-port*)
-(defun socket-server (host port function &optional arguments
- &key (timeout 1)
- (max-buffer-size +max-datagram-packet-size+))
- (let ((socket (socket-connect nil nil
- :protocol :datagram
- :local-host host
- :local-port port))
- (buffer (make-array max-buffer-size
- :element-type '(unsigned-byte 8)
- :initial-element 0)))
+(defun default-udp-handler (buffer) ; echo
+ (declare (type (simple-array (unsigned-byte 8) *) buffer))
+ buffer)
+
+(defun udp-event-loop (socket function &optional arguments
+ &key timeout max-buffer-size)
+ (let ((buffer (make-array max-buffer-size :element-type '(unsigned-byte 8) :initial-element 0))
+ (sockets (list socket)))
+ (unwind-protect
+ (loop do
+ (multiple-value-bind (return-sockets real-time)
+ (wait-for-input sockets :timeout timeout)
+ (declare (ignore return-sockets))
+ (when real-time
+ (multiple-value-bind (recv n *remote-host* *remote-port*)
+ (socket-receive socket buffer max-buffer-size)
+ (declare (ignore recv))
+ (if (plusp n)
+ (progn
+ (let ((reply
+ (apply function (subseq buffer 0 n) arguments)))
+ (when reply
+ (replace buffer reply)
+ (let ((n (socket-send socket buffer (length reply)
+ :host *remote-host*
+ :port *remote-port*)))
+ (when (minusp n)
+ (error "send error: ~A~%" n))))))
+ (error "receive error: ~A" n))))
+ #+scl (when thread:*quitting-lisp* (return))
+ #+(and cmu mp) (mp:process-yield))))
+ (socket-close socket)
+ (values)))
+
+(defun default-tcp-handler (stream) ; null
+ (declare (type stream stream))
+ (terpri stream))
+
+(defun tcp-event-loop (socket function &optional arguments
+ &key element-type multi-threading)
+ (let ((real-function #'(lambda (client-socket &rest arguments)
+ (unwind-protect
+ (apply function (socket-stream client-socket) arguments)
+ (close (socket-stream client-socket))
+ (socket-close client-socket)))))
(unwind-protect
- (loop (progn
- (multiple-value-bind (sockets real-time)
- (wait-for-input socket :timeout timeout)
- (declare (ignore sockets))
- (when real-time
- (multiple-value-bind (recv n *remote-host* *remote-port*)
- (socket-receive socket buffer max-buffer-size)
- (declare (ignore recv))
- (if (plusp n)
- (progn
- (let ((reply
- (apply function
- (cons (subseq buffer 0 n) arguments))))
- (when reply
- (replace buffer reply)
- (let ((n (socket-send socket buffer (length reply)
- :host *remote-host*
- :port *remote-port*)))
- (when (minusp n)
- (error "send error: ~A~%" n))))))
- (error "receive error: ~A" n))))
- #+scl (when thread:*quitting-lisp*
- (return))
- #+(and cmu mp) (mp:process-yield))))
+ (loop do
+ (let* ((client-socket (apply #'socket-accept
+ `(,socket ,@(when element-type `(:element-type ,element-type)))))
+ (client-stream (socket-stream client-socket)))
+ (if multi-threading
+ (apply #'spawn-thread "USOCKET Client" real-function client-socket arguments)
+ (prog1 (apply real-function client-socket arguments)
+ (close client-stream)
+ (socket-close client-socket)))
+ #+scl (when thread:*quitting-lisp* (return))
+ #+(and cmu mp) (mp:process-yield)))
(socket-close socket)
(values))))
Modified: usocket/trunk/usocket.asd
==============================================================================
--- usocket/trunk/usocket.asd (original)
+++ usocket/trunk/usocket.asd Mon Jul 12 05:47:40 2010
@@ -22,7 +22,8 @@
(:module "vendor" :depends-on ("package")
:components ((:file "split-sequence")
#+mcl (:file "kqueue")
- #+clozure (:file "ccl-send")))
+ #+openmcl (:file "ccl-send")
+ (:file "spawn-thread")))
(:file "usocket" :depends-on ("vendor"))
(:file "condition" :depends-on ("usocket"))
(:module "backend" :depends-on ("condition")
Added: usocket/trunk/vendor/spawn-thread.lisp
==============================================================================
--- (empty file)
+++ usocket/trunk/vendor/spawn-thread.lisp Mon Jul 12 05:47:40 2010
@@ -0,0 +1,71 @@
+;;;; $Id$
+;;;; $URL$
+
+;;;; SPWAN-THREAD from GBBopen's PortableThreads.lisp
+
+(in-package :usocket)
+
+#+(and digitool ccl-5.1)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (pushnew ':digitool-mcl *features*))
+
+;;; ---------------------------------------------------------------------------
+;;; Add clozure feature to legacy OpenMCL:
+
+#+(and openmcl (not clozure))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (pushnew ':clozure *features*))
+
+;;; ===========================================================================
+;;; Features & warnings
+
+#+(or (and clisp (not mt))
+ cormanlisp
+ (and cmu (not mp))
+ (and ecl (not threads))
+ gcl
+ (and sbcl (not sb-thread)))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (pushnew ':threads-not-available *features*))
+
+;;; ---------------------------------------------------------------------------
+
+#+threads-not-available
+(defun threads-not-available (operation)
+ (warn "Threads are not available in ~a running on ~a; ~s was used."
+ (lisp-implementation-type)
+ (machine-type)
+ operation))
+
+;;; ===========================================================================
+;;; Spawn-Thread
+
+(defun spawn-thread (name function &rest args)
+ #-(or (and cmu mp) cormanlisp (and sbcl sb-thread))
+ (declare (dynamic-extent args))
+ #+allegro
+ (apply #'mp:process-run-function name function args)
+ #+(and clisp mt)
+ (mt:make-thread #'(lambda () (apply function args))
+ :name name)
+ #+clozure
+ (apply #'ccl:process-run-function name function args)
+ #+(and cmu mp)
+ (mp:make-process #'(lambda () (apply function args))
+ :name name)
+ #+digitool-mcl
+ (apply #'ccl:process-run-function name function args)
+ #+(and ecl threads)
+ (apply #'mp:process-run-function name function args)
+ #+lispworks
+ (apply #'mp:process-run-function name nil function args)
+ #+(and sbcl sb-thread)
+ (sb-thread:make-thread #'(lambda () (apply function args))
+ :name name)
+ #+scl
+ (mp:make-process #'(lambda () (apply function args))
+ :name name)
+ #+threads-not-available
+ (declare (ignore name function args))
+ #+threads-not-available
+ (threads-not-available 'spawn-thread))
More information about the usocket-cvs
mailing list