;; (require :read-sequence-star) (in-package :read-sequence-star) ;;;; -- Networking and Multithreading --------------------------------------------------------- (defun make-listener (&key host port (reuse-address-p t) (nodelay nil) (backlog 5)) #+SBCL (let ((socket (make-instance 'sb-bsd-sockets:inet-socket :type :stream :protocol :tcp))) (when reuse-address-p (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)) (when nodelay (setf (sb-bsd-sockets:sockopt-tcp-nodelay socket) t)) (sb-bsd-sockets:socket-bind socket (if host (sb-bsd-sockets:host-ent-address (sb-bsd-sockets:get-host-by-name host)) #(0 0 0 0)) port) (sb-bsd-sockets:socket-listen socket backlog) socket) #+CCL (ccl:make-socket :address-family :internet :local-port port :local-host host :connect :passive :reuse-address reuse-address-p :nodelay t :backlog backlog :nodelay nodelay)) (defun close-listener (listener) #+SBCL (sb-bsd-sockets:socket-close listener) #+CCL (close listener)) (defun accept-connection (listener &rest stream-options &key (element-type 'character) external-format timeout) (declare (ignorable element-type external-format timeout)) #+SBCL (let ((stream-options (let ((stream-options (copy-list stream-options))) (remf stream-options :timeout) stream-options))) (let* ((socket (handler-bind ((sb-sys:deadline-timeout (lambda (c) (declare (ignore c)) (return-from accept-connection (values nil ':timeout))))) (if timeout (sb-sys:with-deadline (:seconds timeout) (sb-bsd-sockets:socket-accept listener)) (sb-bsd-sockets:socket-accept listener)))) (peer (sb-bsd-sockets::socket-peerstring socket))) (values (apply #'sb-bsd-sockets:socket-make-stream socket :input t :output t stream-options) peer))) #+CCL (let* ((stream-args (let ((q (copy-list stream-options))) (remf q :element-type) (remf q :timeout) (list* :format (if (subtypep element-type 'integer) ':binary ':text) q))) (io (ccl::with-process-whostate ("Listening for connection") (ccl:accept-connection listener :wait t :stream-args (list* :sharing nil stream-args)))) (peer (typecase io (ccl::tcp-stream (format nil "~A:~A" (ccl:ipaddr-to-dotted (ccl:remote-host io)) (ccl:remote-port io))) (t nil)))) (values io peer))) (defun tcp-connect (host port &rest stream-options &key (timeout nil) element-type external-format) (declare (ignorable element-type external-format)) #+CCL (let ((stream-options (let ((stream-options (copy-list stream-options))) (remf stream-options :timeout) (remf stream-options :element-type) (push (if (subtypep element-type 'integer) :binary :text) stream-options) (push :format stream-options) stream-options))) (apply #'ccl:make-socket :remote-host host :remote-port port :connect-timeout timeout :sharing nil stream-options)) #+SBCL (let ((stream-options (let ((stream-options (copy-list stream-options))) (remf stream-options :timeout) stream-options))) (let* ((sock (make-instance 'sb-bsd-sockets:inet-socket :protocol :tcp :type :stream)) (addr (car (sb-bsd-sockets:host-ent-addresses (sb-bsd-sockets:get-host-by-name host))))) (unwind-protect (progn (if timeout (sb-ext:with-timeout timeout (sb-bsd-sockets:socket-connect sock addr port)) (sb-bsd-sockets:socket-connect sock addr port)) (sb-sys:without-interrupts (prog1 (apply #'sb-bsd-sockets:socket-make-stream sock :input t :output t stream-options) (setq sock nil)))) (when sock (ignore-errors (sb-bsd-sockets:socket-close sock))))))) #+CCL (progn (defvar +utf-8+ ':utf-8) (defvar +iso-8859-1+ ':iso-8859-1) (defvar +iso-8859-1/crlf+ (ccl:make-external-format :character-encoding :iso-8859-1 :line-termination :dos)) (defun make-process (function &key name) (ccl:process-run-function (or name "Anonymous") function)) (defun destroy-process (process) (ccl:process-kill process)) (defun current-process () ccl:*current-process*) (defun initial-process () ccl::*initial-process*) ;extension (defun all-processes () (ccl:all-processes)) (defun processp (object) (typep object 'ccl:process)) (defun process-name (process) (ccl:process-name process)) (defun process-state (process) (declare (ignore process)) nil) (defun process-whostate (process) (ccl:process-whostate process)) (defun process-wait (whostate predicate) (ccl:process-wait whostate predicate)) (defun process-wait-with-timeout (whostate timeout predicate) (if timeout (ccl:process-wait-with-timeout whostate (round (* timeout ccl:*ticks-per-second*)) predicate) (ccl:process-wait whostate predicate))) (defun process-yield () (sleep 0)) (defun process-interrupt (process function) (ccl:process-interrupt process function)) (defmacro atomic-incf (place) `(ccl::atomic-incf ,place)) (defmacro atomic-decf (place) `(ccl::atomic-decf ,place)) (defun make-lock (&optional name) (ccl:make-lock (or name "Anonymous lock"))) (defun make-recursive-lock (&optional name) (ccl:make-lock (or name "Anonymous recursive lock"))) (defmacro with-lock-held (&whole whole (place &optional whostate) &body body) (declare (ignorable whole place whostate body)) (if whostate `(ccl:with-lock-grabbed (,place ,whostate) ,@body) `(ccl:with-lock-grabbed (,place) ,@body))) (defmacro with-recursive-lock-held (&whole whole (place &optional whostate) &body body) (declare (ignorable whole place whostate body)) (if whostate `(ccl:with-lock-grabbed (,place ,whostate) ,@body) `(ccl:with-lock-grabbed (,place) ,@body))) (defun make-semaphore (&key (name nil name-p)) (declare (ignore name name-p)) (ccl:make-semaphore)) (defun wait-on-semaphore (semphore &key timeout) (if timeout (ccl:timed-wait-on-semaphore semphore timeout) (progn (ccl:wait-on-semaphore semphore) 't))) (defun signal-semaphore (semphore) (ccl:signal-semaphore semphore)) (defmacro without-interrupts (&body body) `(ccl:without-interrupts ,@body)) (defmacro with-process-whostate ((whostate) &body body) `(ccl::with-process-whostate (,whostate) ,@body)) ) #+SBCL (progn (defvar +utf-8+ ':utf-8) (defvar +iso-8859-1+ ':iso-8859-1) (defun make-process (function &rest args &key name) (declare (ignore name)) (apply #'sb-thread:make-thread function args)) (defun destroy-process (process) (sb-thread:destroy-thread process)) (defun current-process () sb-thread:*current-thread*) (defun initial-process () sb-thread::*initial-thread*) (defun all-processes () (sb-thread:list-all-threads)) (defun processp (object) (typep object 'sb-thread:thread)) (defun process-name (process) (sb-thread:thread-name process)) (defun process-state (process) nil) (defun process-whostate (process) "Run") (defun process-wait (whostate predicate) (loop until (funcall predicate) do (sleep 1/100))) (defun process-wait-with-timeout (whostate timeout predicate) (if timeout (let ((dead-line (+ (get-internal-real-time) (round (* timeout internal-time-units-per-second)))) it) (loop (cond ((>= (get-internal-real-time) dead-line) (return nil)) ((setq it (funcall predicate)) (return it))) (sleep 1/100))) (process-wait whostate predicate))) (defun process-yield () (sleep 0)) (defun process-interrupt (process function) (sb-thread:interrupt-thread process function)) (defmacro atomic-incf (place) `(sb-ext:atomic-incf ,place)) (defmacro atomic-decf (place) `(sb-ext:atomic-decf ,place)) (defun make-lock (&optional name) (sb-thread:make-mutex :name (with-standard-io-syntax (princ-to-string name)))) (defun make-recursive-lock (&optional name) (sb-thread:make-mutex :name (with-standard-io-syntax (princ-to-string name)))) (defmacro with-lock-held (&whole whole (place &optional whostate) &body body) (declare (ignore whostate)) `(sb-thread:with-recursive-lock (,place) ,@body)) (defmacro with-recursive-lock-held (&whole whole (place &optional whostate) &body body) `(sb-thread:with-recursive-lock (,place) ,@body)) (defun make-semaphore (&key (name nil name-p)) (if name-p (sb-thread:make-semaphore :name name) (sb-thread:make-semaphore))) (defun wait-on-semaphore (semphore &key timeout) (if timeout (sb-thread:wait-on-semaphore semphore :timeout (max 1e-6 timeout)) (sb-thread:wait-on-semaphore semphore))) (defun signal-semaphore (semphore) (sb-thread:signal-semaphore semphore)) (defmacro without-interrupts (&body body) `(sb-sys:without-interrupts (sb-sys:allow-with-interrupts ,@body))) (defmacro with-process-whostate ((whostate) &body body) (declare (ignore whostate)) `(locally ,@body)) ) ;;;; ------------------------------------------------------------------------------------------ (defun test-server (&key (port 1337)) (let ((listener (make-listener :port port))) (format t "~&Listening on port ~D~%" port) (unwind-protect (loop (multiple-value-bind (io peer) (accept-connection listener :element-type '(unsigned-byte 8)) (format t "~&Connection from ~A~%" peer) (unwind-protect (let ((buf (make-array 512 :element-type '(unsigned-byte 8)))) (loop (multiple-value-bind (end status) (read-sequence* buf io :timeout 5 :short t) (format t "~&status = ~S, end = ~D~%" status end) (when (eq status ':eof) (return)))) (format t "~&Connection gone~%")) (close io)))) (close-listener listener))))