From a2b021b48fc85a5cf2a2f230929045caccebe6b6 Mon Sep 17 00:00:00 2001 From: "Chun Tian (binghe)" Date: Tue, 25 Oct 2016 09:57:20 +0200 Subject: [PATCH] [server] separated usocket-server system; re-depend on portable-threads (server only) & split-sequence. --- CHANGES | 2 +- package.lisp | 4 +- server.lisp | 7 +- test/package.lisp | 3 - usocket.asd | 22 ++-- vendor/spawn-thread.lisp | 78 ------------ vendor/split-sequence.lisp | 245 ------------------------------------- 7 files changed, 22 insertions(+), 339 deletions(-) delete mode 100644 vendor/spawn-thread.lisp delete mode 100644 vendor/split-sequence.lisp diff --git a/CHANGES b/CHANGES index 8a2c489..16e5d75 100644 --- a/CHANGES +++ b/CHANGES @@ -109,4 +109,4 @@ [TODO] * New feature: CLISP support some advanced TCP features which CLISP's SOCKET interface not provide -* New feature: SOCKET-SHUTDOWN for TCP and UDP sockets. + diff --git a/package.lisp b/package.lisp index d2f1d23..0998886 100644 --- a/package.lisp +++ b/package.lisp @@ -1,7 +1,8 @@ ;;;; See the LICENSE file for licensing information. (defpackage :usocket - (:use :common-lisp #+abcl :java) + (:use :common-lisp #+abcl :java + :split-sequence) (:export #:*version* #:*wildcard-host* #:*auto-port* @@ -25,7 +26,6 @@ #:socket-send ; udp function (send) #:socket-receive ; udp function (receive) - #:socket-server ; udp server #:socket-option ; 0.6.x #:wait-for-input ; waiting for input-ready state (select() like) diff --git a/server.lisp b/server.lisp index e050d13..55bd874 100644 --- a/server.lisp +++ b/server.lisp @@ -1,8 +1,9 @@ -;;;; $Id$ -;;;; $URL$ - (in-package :usocket) +(eval-when (:compile-toplevel :load-toplevel :execute) + (use-package :portable-threads) + (export 'socket-server)) + (defun socket-server (host port function &optional arguments &key in-new-thread (protocol :stream) ;; for udp diff --git a/test/package.lisp b/test/package.lisp index 15935dc..16ad1ab 100644 --- a/test/package.lisp +++ b/test/package.lisp @@ -1,6 +1,3 @@ -;;;; $Id$ -;;;; $URL$ - ;;;; See the LICENSE file for licensing information. (in-package :cl-user) diff --git a/usocket.asd b/usocket.asd index 7426b8d..0af572a 100644 --- a/usocket.asd +++ b/usocket.asd @@ -3,19 +3,18 @@ ;;;; See the LICENSE file for licensing information. (defsystem usocket - :name "usocket" + :name "usocket (client)" :author "Erik Enge & Erik Huelsmann" :maintainer "Chun Tian (binghe) & Hans Huebner" :version "0.6.6-dev" :licence "MIT" :description "Universal socket library for Common Lisp" - :depends-on (#+(or sbcl ecl) :sb-bsd-sockets) + :depends-on (#+(or sbcl ecl) :sb-bsd-sockets + :split-sequence) :components ((:file "package") (:module "vendor" :depends-on ("package") :components (#+mcl (:file "kqueue") - #+mcl (:file "OpenTransportUDP") - (:file "spawn-thread") - (:file "split-sequence"))) + #+mcl (:file "OpenTransportUDP"))) (:file "usocket" :depends-on ("vendor")) (:file "condition" :depends-on ("usocket")) (:module "backend" :depends-on ("condition") @@ -32,9 +31,18 @@ #+openmcl (:file "openmcl") #+(or ecl sbcl) (:file "sbcl") #+scl (:file "scl"))) - (:file "option" :depends-on ("backend")) - (:file "server" :depends-on ("backend" "option")))) + (:file "option" :depends-on ("backend")))) + +(defsystem usocket-server + :name "usocket (server)" + :author "Chun Tian (binghe)" + :version "1.0" + :licence "MIT" + :description "Universal socket library for Common Lisp (server side)" + :depends-on (:usocket :portable-threads) + :components ((:file "server"))) (defmethod perform ((op test-op) (c (eql (find-system :usocket)))) + (oos 'load-op :usocket-server) (oos 'load-op :usocket-test) (oos 'test-op :usocket-test)) diff --git a/vendor/spawn-thread.lisp b/vendor/spawn-thread.lisp deleted file mode 100644 index 81aa57a..0000000 --- a/vendor/spawn-thread.lisp +++ /dev/null @@ -1,78 +0,0 @@ -;;;; $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 - mocl - (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)) - #+abcl - (threads:make-thread #'(lambda () (apply function args)) - :name name) - #+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) - #+abcl - (threads:make-thread #'(lambda () (apply function args)) - :name name) - #+threads-not-available - (declare (ignore name function args)) - #+threads-not-available - (threads-not-available 'spawn-thread)) diff --git a/vendor/split-sequence.lisp b/vendor/split-sequence.lisp deleted file mode 100644 index 6701b8c..0000000 --- a/vendor/split-sequence.lisp +++ /dev/null @@ -1,245 +0,0 @@ -;;;; SPLIT-SEQUENCE -;;; -;;; This code was based on Arthur Lemmens' in -;;; ; -;;; -;;; 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*)