[clisp-list] read-line (clisp 2.30/woody)

[Michael K. <kr...@co...>]

Moin Guru's,

  attached to this mail is my first Common Lisp programm *blush* and
  *uhm well* i did some EMACS/LISP before and i have some reason for
  choosing LISP as the implementation language.
  
  The code fails with related problems.

  - the input method of mucl client does not detect end-of-file.
    There will be a last :input on socket-status, when the client
    closes the connection. The following read() system call, should
    result in 0 or -1. That has to be interpreted as :eof or something
    like that in read-char and read-char-no-hang. So read-line can
    detect it. The :eof will be once raised as non-blocking input
    followed with read() result of -1, and later as an error OF THE
    select() system call.

  - There is a race condition, if the client closed its connection
    during 'tick' (asuming that tick may take longer) between the
    :input and :output socket-status querys. In this case, the
    following socket-status will result in :output (and not :error
    as expected), but a write-line will trigger a SIG_PIPE.
    The race condition could be solved, if the second socket-status
    queries :io and input, is processed before output (for a 2nd
    time) and the read-line end-of-file problem is solved.
    But: how to catch broken pipe signals, as the server should run,
    or is it better (implementation problem similar to Perl) to
    ignore the signal ?

  - Once a client dropped its connection a dead socket is in the
    readfds list. This will cause a socket-status :input to return
    immediate, but the dead socket is neither at :input (for reading
    :eof like the first time directly after client dropped its
    connection) and also not in :error state. Its just nil, so
    the timeout is never reached, and the process is running wild
    till next tick, where it will die with a SIG_PIPE.

  - The code will have to deal with nasty telnet protocols (IAC
    options and commands) are there any low level system-read or
    system-write commands, working more reliable in that context ?

  I've tried several ways to call read-line. e.g as
  (read-line stream nil :my-eof-symbol) but none of them showed
  any end of file condition. I at last tried to read the characters
  one by one - and suprisingly: The -1 from read() system call, is
  interpreted as #\Newline ? So i think i'm lost and hope that someone
  points me to the right place, where to patch read-char and read-line.

  If you want to try the code :

  - install the real read-line again
    g/^.multiple-value-bind/s/mucl-read-line/read-line/
  - start clisp interactive ([m-x]run-lisp)

    (load "mucl-stream")
    (progn
      (unless mucl-running (mucl-open (make-instance 'mucl-server)))
      (setf (mucl-time mucl-running) (truncate (get-internal-real-time) 1000000))
      (setf (mucl-tick mucl-running) (* (truncate (mucl-time mucl-running) 30) 30))
      (dotimes (i 100) (mucl-pulse mucl-running)) )

  - telnet localhost 5555, type something, and look about tick.
    close telnet connection.
  - investigate the clisp debuging output.

  *uh* yes i know lot of this code could/should be improved - PLEASE
  drop me a mail, if your eye catches something that me did plain wrong.

peace on your way,
  Michael

;;; mucl-stream MUCL - Multi User Common Lisp Stream Classes
;;; (c) GNU GPL 2003 

;;; debugging

(defvar mucl-demon nil "demon mode")
(defun mucl-debug (s) "write debug messages, if not in demon mode"
  (unless mucl-demon (write-line s)) nil)
(defvar mucl-running nil "the running MUCL server")

;;; class definitions

(defclass mucl-stream ()
  ((sock :accessor mucl-sock :initarg :sock))
  (:documentation "The basic MUCL stream class"))
(defclass mucl-server (mucl-stream)
  ((port :accessor mucl-port :initform 5555)
   (peer :accessor mucl-peer)
   (hash :accessor mucl-hash)
   (tick :accessor mucl-tick)
   (time :accessor mucl-time))
  (:documentation "The MUCL server stream class"))
(defclass mucl-client (mucl-stream)
  ((buff :accessor mucl-buff)
   (ique :accessor mucl-ique)
   (oque :accessor mucl-oque))
  (:documentation "The MUCL client stream class"))

;;; method definitions

(defgeneric mucl-open  (mucl-stream &optional port)
  (:documentation "Open the object"))
(defgeneric mucl-close (mucl-stream)
  (:documentation "Close the object"))
(defgeneric mucl-input (mucl-stream)
  (:documentation "Receive input"))
(defgeneric mucl-output (mucl-stream)
  (:documentation "Send output"))
(defgeneric mucl-error (mucl-stream)
  (:documentation "Process error"))
(defgeneric mucl-pulse (mucl-stream)
  (:documentation "Process pulse"))

;;; mucl-server implementation

(defmethod mucl-open ((self mucl-server) &optional port)
  (when port (setf (mucl-port self) port))
  (setf (mucl-sock self) (socket-server (mucl-port self)))
  (setf (mucl-peer self) nil)
  (setf (mucl-hash self) nil)
  (setq mucl-running self)
  (mucl-debug "MUCL server open") )
(defmethod mucl-close ((self mucl-server))
  (socket-server-close (mucl-sock self))
  (setf (mucl-sock self) nil)
  (setq mucl-running nil)
  (mucl-debug "MUCL server close") )
(defmethod mucl-input ((self mucl-server))
  (let ((p (make-instance 'mucl-client)))
    (mucl-open p (socket-accept (mucl-sock self)))
    (mucl-debug "MUCL server accept") ))
(defmethod mucl-output ((self mucl-server))
  (mucl-debug "MUCL server output error")
  (mucl-close self))
(defmethod mucl-error ((self mucl-server))
  (mucl-debug "MUCL server error")
  (mucl-close self))
(defmethod mucl-pulse ((self mucl-server))
  (let (socks stats time)
    (when mucl-running
      (setq socks (cons (mucl-sock self)
			(mapcar #'(lambda (s)
				    (cons (mucl-sock s) :input))
				(mucl-peer self)) ))
      (setq stats (socket-status socks 5 50000))
      (mucl-stream-loop socks stats) )
    (setq time (truncate (get-internal-real-time) 1000000))
    (when (>= time (mucl-tick self))
      (setf (mucl-tick self) (+ (mucl-tick self) 30))
      (mucl-debug (format nil "MUCL server tick ~A"
			  (mucl-date time) ))
      (let ((s (format nil "tick ~A~%" (mucl-date time)) ))
	(dolist (p (mucl-peer self)) (mucl-queue p s))))
    (when (and mucl-running (mucl-peer self))
      (setq socks (mapcar #'(lambda (s)
			      (cons (mucl-sock s) :output))
			  (mucl-peer self)) )
      (setq stats (socket-status socks 0 50000))
      (mucl-stream-loop socks stats) )))

;;; MUCL client method implementation

(defmethod mucl-open ((self mucl-client) &optional sock)
  (when sock
    (setf (mucl-oque self) nil)
    (setf (mucl-ique self) nil)
    (setf (mucl-buff self) nil)
    (setf (mucl-sock self) sock)
    (setf (mucl-hash mucl-running) nil)
    (push self (mucl-peer mucl-running))
    (mucl-debug "MUCL client open") ))
(defmethod mucl-close ((self mucl-client))
  (close (mucl-sock self))
  (setf (mucl-sock self) nil)
  (setf (mucl-hash mucl-running) nil)
  (delete self (mucl-peer mucl-running))
  (mucl-debug "MUCL client close") )
(defun mucl-read-line (stream)
  (let ((buffer (make-array 10 :element-type 'character
			    :adjustable t :fill-pointer 0)))
    (loop
     (let ((c (read-char stream)))
       (mucl-debug (format nil "[~A]" c))
       (cond ((not c)
	      (return (values nil t)))
	     ((eq c ':EOF)
	      (return (values (coerce buffer 'simple-string) t)))
	     ((eql c #\Newline)
	      (return (values (coerce buffer 'simple-string) nil)))
	     (t (vector-push-extend c buffer))
	     )))))
(defmethod mucl-input ((self mucl-client))
  (multiple-value-bind (l f) (mucl-read-line (mucl-sock self))
    (mucl-debug (format nil "MUCL process (~A|~A)~%" l f))
    (if (or f (not l))
	(mucl-close self)
      (mucl-debug (format nil "MUCL process (~A)~%" l)) )))
(defmethod mucl-output ((self mucl-client))
  (when (mucl-oque self)
    (write-string (car (mucl-oque self)) (mucl-sock self))
    (setf (mucl-oque self) (cdr (mucl-oque self))) ))
(defmethod mucl-error ((self mucl-client))
  (mucl-debug "MUCL client error")
  (mucl-close self) )
(defun mucl-queue (client string) "queue a string to send a client"
  (setf (mucl-oque client) (append (mucl-oque client) (list string))))

;;; control functions

(defun mucl-stream-loop (socks stats) "loop over socket status"
  (unless (mucl-hash mucl-running)
    (setf (mucl-hash mucl-running)
	  (cons
	   (cons (mucl-sock mucl-running) mucl-running)
	   (mapcar #'(lambda (s)
		       (cons (mucl-sock s) s))
		   (mucl-peer mucl-running)) )))
  (loop
   (unless (car socks) (return))
   (let ((csock (car socks))
	 (cstat (car stats))
	 cstream)
     (when (listp csock) (setq csock (car csock)))
     (setq cstream (cdr (assoc csock (mucl-hash mucl-running))))
     (format t "MUCL check ~A stat ~A~%" csock cstat)
     (if cstream
	 (case cstat
	   ((t :input) (mucl-input cstream))
	   (:output (mucl-output cstream))
	   (:error (mucl-error cstream))
	   (otherwise (when cstat
			(format t "MUCL error ~A stat ~A~%" csock cstat)
			(mucl-error cstream))))
	(format t "MUCL error no object ~A stat ~A hash ~A"
		csock cstat (mucl-hash mucl-running)) ))
   (unless (cdr socks) (return))
   (setq stats (cdr stats))
   (setq socks (cdr socks)) ))
(defun mucl-start () "start MUCL"
  (unless mucl-running (mucl-open (make-instance 'mucl-server)))
  (setf (mucl-time mucl-running) (truncate (get-internal-real-time) 1000000))
  (setf (mucl-tick mucl-running) (* (truncate (mucl-time mucl-running) 30) 30))
  (loop (unless mucl-running (return)) (mucl-pulse mucl-running)) )
(defun mucl-stop () "stop MUCL"
  (when mucl-running (mucl-close mucl-running)))
(defun mucl-date (time &optional shift) "traveller GAME time"
  (let (year date hour min)
    (setq year (truncate time 518400))
    (setq date (- (truncate time 1440) (* year 360)))
    (setq hour (- (truncate time 60) (+ (* year 360 24) (* date 24))))
    (setq min (- time (+ (* hour 60) (* year 518400) (* date 1440))))
    (when shift (setq year (+ year shift)))
    (setq str (format nil "~4D-~3,'0D ~2,'0D:~2,'0D" year date hour min))
    str))

; mailto:kr...@co...             UNA:+.? 'CED+2+:::Linux:2.4.6'UNZ+1'
; http://www.xml-edifact.org/           CETERUM CENSEO WINDOWS ESSE DELENDAM