Corrected dead-lock due to recursive locking (ccl only has recursive locks). Corrected FOR-EACH-LINE macro.

Pascal J. Bourguignon [2021-05-23 08:21]
Corrected dead-lock due to recursive locking (ccl only has recursive locks).  Corrected FOR-EACH-LINE macro.
Filename
clext/telnet/telnet-repl.lisp
clext/telnet/telnet-stream-test.lisp
clext/telnet/telnet-stream.lisp
clext/telnet/test-stub-nvt.lisp
diff --git a/clext/telnet/telnet-repl.lisp b/clext/telnet/telnet-repl.lisp
index 0c044d3..8998116 100644
--- a/clext/telnet/telnet-repl.lisp
+++ b/clext/telnet/telnet-repl.lisp
@@ -5,9 +5,9 @@
 ;;;;SYSTEM:             Common-Lisp
 ;;;;USER-INTERFACE:     NONE
 ;;;;DESCRIPTION
-;;;;
+;;;;
 ;;;;    Implements a Telnet REPL server.
-;;;;
+;;;;
 ;;;;AUTHORS
 ;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
 ;;;;MODIFICATIONS
@@ -15,19 +15,19 @@
 ;;;;BUGS
 ;;;;LEGAL
 ;;;;    AGPL3
-;;;;
+;;;;
 ;;;;    Copyright Pascal J. Bourguignon 2021 - 2021
-;;;;
+;;;;
 ;;;;    This program is free software: you can redistribute it and/or modify
 ;;;;    it under the terms of the GNU Affero General Public License as published by
 ;;;;    the Free Software Foundation, either version 3 of the License, or
 ;;;;    (at your option) any later version.
-;;;;
+;;;;
 ;;;;    This program is distributed in the hope that it will be useful,
 ;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;;;;    GNU Affero General Public License for more details.
-;;;;
+;;;;
 ;;;;    You should have received a copy of the GNU Affero General Public License
 ;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
 ;;;;**************************************************************************
@@ -101,18 +101,29 @@
    (login-function    :initarg :login-function    :reader login-function)
    (repl-function     :initarg :repl-function     :reader repl-function)
    (stop-closure      :initarg :stop-closure      :reader stop-closure)
-   (terminate-closure :initarg :terminate-closure :reader terminate-closure)))
+   (terminate-closure :initarg :terminate-closure :reader terminate-closure)
+   (stream            :initarg :stream            :reader repl-client-stream)))

+(defvar *stream* nil)
 (defun run-client-loop (client)
-  (with-telnet-on-stream (stream (socket-stream (repl-client-socket client)))
-    (when (and (not (stop-closure client))
+  (with-telnet-on-stream (stream (socket-stream (repl-client-socket client))
+                                 client)
+    (setf  *stream* stream)
+    (setf (slot-value client 'stream) stream)
+    (format *log-output* "~&client ~D telnet on stream ~S~%" (repl-client-number client) stream)
+    (print (list :not-stop (not (stop-closure client))
+                 :banner (banner-function client)
+                 :login (login-function client))
+           *log-output*)
+    (terpri *log-output*)
+    (when (and (not (funcall (stop-closure client)))
                (banner-function client))
       (funcall (banner-function client) stream (repl-client-number client) (name client)))
-    (when (and (not (stop-closure client))
+    (when (and (not (funcall (stop-closure client)))
                (or (null    (login-function client))
                    (funcall (login-function client) stream)))
-      (funcall (repl-function client) stream (repl-client-number client)
-               (stop-closure client)))))
+      (funcall (repl-function client) stream (repl-client-number client) (stop-closure client))
+      (format *log-output* "~&client ~D repl-function returned~%" (repl-client-number client)))))

 (defmethod initialize-instance :after ((client repl-client) &key &allow-other-keys)
   (setf (slot-value client 'thread)
@@ -180,7 +191,8 @@
       :for cn :from 1
       :for client-socket := (socket-accept server-socket
                                            :element-type 'octet)
-      :when client-socket
+      :when client-socket
+        :do (format *log-output* "~&connection from ~S~%" client-socket)
         :do (with-lock-held ((repl-server-lock server))
               (let ((client (make-instance
                              'repl-client
@@ -208,13 +220,13 @@
             (when stop-it
               (setf stop t))
             stop)
-
+
           (slot-value server 'lock)
           (make-lock (format nil "~A Server Lock" (name server)))

           (slot-value server 'more-clients)
           (make-condition-variable :name (format nil "~A Server More Clients" (name server)))
-
+
           (slot-value server 'thread)
           (make-thread (lambda () (run-server-loop server))
                        :name (format nil "~A Server" (name server))))))
@@ -258,7 +270,6 @@ the REPL clients, but the REPL server should not accept new
 connections right away."
   (when (repl-server-thread server)
     (funcall (must-stop-p server) t)
-    (join-thread (repl-server-thread server))
     (%clean-up server))
   nil)

diff --git a/clext/telnet/telnet-stream-test.lisp b/clext/telnet/telnet-stream-test.lisp
new file mode 100644
index 0000000..344fdda
--- /dev/null
+++ b/clext/telnet/telnet-stream-test.lisp
@@ -0,0 +1,76 @@
+(defpackage "COM.INFORMATIMAGO.CLEXT.TELNET.STREAM.TEST"
+  (:use "COMMON-LISP"
+        "BORDEAUX-THREADS"
+        "TRIVIAL-GRAY-STREAMS"
+        "COM.INFORMATIMAGO.COMMON-LISP.TELNET"
+        "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.ASCII"
+        "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.CHARACTER-SETS"
+        "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.ARRAY"
+        "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.STRING"
+        "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.SIMPLE-TEST"
+        "COM.INFORMATIMAGO.CLEXT.CHARACTER-SETS"
+        "COM.INFORMATIMAGO.CLEXT.BABEL-EXTENSION"
+        "COM.INFORMATIMAGO.CLEXT.TELNET.STREAM"
+        "COM.INFORMATIMAGO.CLEXT.TELNET.TEST.STUB-NVT")
+  (:import-from "COM.INFORMATIMAGO.CLEXT.TELNET.STREAM"
+                "MAKE-BINARY-BUFFER" "NVT" "OUTPUT-BUFFER"
+                "ENCODE-STRING-TO-OUTPUT-BUFFER"
+                )
+  (:export "TEST/ALL"))
+(in-package "COM.INFORMATIMAGO.CLEXT.TELNET.STREAM.TEST")
+
+(define-test test/replace-octets-by-string ()
+  (let ((buffer (make-binary-buffer 100)))
+    (let* ((string "Hello World")
+           (bytes (map 'vector 'ascii-code string)))
+
+      (setf (fill-pointer buffer) (array-dimension buffer 0))
+      (multiple-value-bind (filledp size)
+          (replace-octets-by-string buffer string
+                                    :start1 0
+                                    :encoding :us-ascii)
+
+        (assert-true filledp (buffer string :us-ascii)
+                     "~S could not fill the buffer."
+                     'replace-octets-by-string)
+
+        (assert-true (= (length string) size)
+                     (buffer string :us-ascii)
+                     "~S didn't filled only ~D bytes instead of expected ~D bytes."
+                     'replace-octets-by-string
+                     size
+                     (length string))
+
+        (assert-true (= size (mismatch buffer bytes :end1 size)))
+
+        (setf (fill-pointer buffer) size)
+        (check equalp buffer bytes)))))
+
+
+(define-test test/encode-string-to-output-buffer ()
+  (let* ((stream (make-instance 'telnet-stream
+                                :element-type 'character))
+         (nvt    (make-instance 'stub-nvt
+                                :name "STUB NVT"
+                                :client nil
+                                :up-sender stream
+                                :down-sender nil)))
+    (setf (slot-value stream 'nvt) nvt)
+    (let* ((buffer (output-buffer stream))
+           (s1 "Hello ")
+           (s2 "World!")
+           (s1+s2 (concatenate 'string s1 s2))
+           (bytes (map 'vector 'ascii-code s1+s2)))
+      (check = (fill-pointer buffer) 0 (buffer))
+      (encode-string-to-output-buffer stream s1)
+      (check = (fill-pointer buffer) (length s1) (buffer))
+      (encode-string-to-output-buffer stream s2)
+      (check = (fill-pointer buffer) (length s1+s2) (buffer))
+      (check equalp buffer bytes (buffer bytes)))))
+
+
+(define-test test/all ()
+  (test/replace-octets-by-string)
+  (test/encode-string-to-output-buffer))
+
+(test/all)
diff --git a/clext/telnet/telnet-stream.lisp b/clext/telnet/telnet-stream.lisp
index 1025f3e..d6678c2 100644
--- a/clext/telnet/telnet-stream.lisp
+++ b/clext/telnet/telnet-stream.lisp
@@ -36,6 +36,13 @@
 (in-package "COM.INFORMATIMAGO.CLEXT.TELNET.STREAM")
 (declaim (declaration stepper))

+(defvar *log-output* *trace-output*)
+;; We cannot use *trace-output* while debugging the telnet-repl, since
+;; it's dynamically bound to the telnet-stream for the user.
+(defun format-log (control-string &rest arguments)
+  (format *log-output* "~?" control-string arguments)
+  (finish-output *log-output*))
+
 #|

 # -*- mode:org -*-
@@ -157,6 +164,15 @@ is implemented, at least for the initial external-format).

 ** Buffering

+Note: both for the input buffer and the output buffer, we will use
+octet vectors both for binary and text modes.  The encoding/decoding
+of the text is therefore always performed by the telnet-stream itself.
+The Telnet NVT has been modified to allow either the transmission of
+vector of ascii code octets  or strings for the text mode API.  We use
+only the vector of ascii codes.   The let us avoid copying buffers as
+much as possible.
+
+
 Note: we may ask for the EOR option, and send an EOR when flushing
 (automatic or explicit).

@@ -289,28 +305,30 @@ client input loop thread                  |   .    |
 ;;; Telnet Streams
 ;;;

+(defgeneric start-down-thread (layer))

-(defun call-with-telnet-on-stream (low-stream function)
+(defun call-with-telnet-on-stream (low-stream client function)
   (let* ((stream (make-instance 'telnet-stream
                                 :element-type 'character))
          (down   (make-instance 'down-layer
                                 :stream low-stream
-                                :client nil))
-         (nvt (make-instance 'network-virtual-terminal
-                             :name "TELNET SERVER"
-                             :client nil
-                             :up-sender stream
-                             :down-sender down)))
+                                :client client))
+         (nvt    (make-instance 'network-virtual-terminal
+                                :name "TELNET SERVER"
+                                :client nil ; we're server.
+                                :up-sender stream
+                                :down-sender down)))
     (setf (slot-value stream 'nvt) nvt
           (slot-value down   'nvt) nvt)
+    (start-down-thread down)
     (funcall function stream)))

-(defmacro with-telnet-on-stream ((stream-var stream-expr) &body body)
+(defmacro with-telnet-on-stream ((stream-var stream-expr client) &body body)
   "Connects a telnet network-virtual-terminal to the remote stream
 resulting from the STREAM-EXPR, and evaluates the BODY in a lexical
 context where the STREAM-VAR is bound to a  local bidirectional stream
 conected to the NVt."
-  `(call-with-telnet-on-stream ,stream-expr (lambda (,stream-var) ,@body)))
+  `(call-with-telnet-on-stream ,stream-expr ,client (lambda (,stream-var) ,@body)))

 (deftype octet () `(unsigned-byte 8))

@@ -346,24 +364,39 @@ conected to the NVt."
    (stream      :reader   down-stream :initarg  :stream)
    (client      :reader   client      :initarg  :client)
    (lock        :reader   down-lock)
-   (writingp    :accessor %writingp   :initarg  nil)
-   (down-buffer :reader   down-buffer :initform (make-binary-buffer +down-layer-buffer-size+))))
+   (writingp    :accessor %writingp   :initform nil)
+   (down-buffer :reader   down-buffer :initform (make-binary-buffer +down-layer-buffer-size+))
+   (thread      :reader   down-thread :initform nil)))

 (defgeneric input-loop (down-layer))
 (defgeneric stop-closure (client)) ;; TODO must be imported from telnet.repl

+(defmethod initialize-instance :after ((layer down-layer) &key &allow-other-keys)
+  (setf (slot-value layer 'lock) (make-lock "down-layer")))
+
+(defmethod start-down-thread ((layer down-layer))
+  (setf (slot-value layer 'thread)
+        (make-thread (lambda () (input-loop layer))
+                     :name (format nil "~A DOWN LAYER" (name (client layer))))))
+
 (defmethod input-loop ((self down-layer))
   ;; The input-loop runs in the client input loop thread
   (loop
+    :with stream := (down-stream self)
     :with buffer := (make-binary-buffer +down-layer-buffer-size+)
-    :until (stop-closure (client self))
-    :do (setf (fill-pointer buffer) (array-dimension buffer 0))
-        (let ((last-pos (read-sequence buffer (down-stream self))))
-          (setf (fill-pointer buffer) last-pos))
-        (receive (nvt (client self)) buffer)))
-
-
-(defmethod send ((self down-layer) bytes &key start end)
+    :until (funcall (stop-closure (client self)))
+      :initially (setf (fill-pointer buffer) 1)
+    :do (setf (aref buffer 0) (read-byte stream))
+        (format-log "~&down-layer received from remote: ~S~%"
+                buffer)
+        (force-output *log-output*)
+        (receive (nvt self) buffer)
+        (format-log "~&down-layer: nvt received:       ~S~%"
+                buffer)
+        (force-output *log-output*)))
+
+
+(defmethod send ((self down-layer) bytes &key (start 0) end)
   ;; The send method is called in the client repl thread
   ;; Down interface (to down):
   ;; Send the bytes to the remote NVT.
@@ -373,10 +406,15 @@ conected to the NVt."
     (with-lock-held ((down-lock self))
       (if (%writingp self)
           (progn
+            (format-log "~&down-layer buffers to remote:    ~S~%"
+                        (subseq bytes start end))
             (buffer-append buffer bytes start end)
             (return-from send))
           (setf (%writingp self) t)))
+    (format-log "~&down-layer sends to remote:      ~S~%"
+                (subseq bytes start end))
     (write-sequence bytes stream :start start :end end)
+    (force-output stream)
     ;; Either we write sequence with lock held, or we need a
     ;; double-buffering to be able to write a buffer while we append
     ;; to the other.  The double-buffer would be better in case of
@@ -385,6 +423,8 @@ conected to the NVt."
     ;; So this should do better:
     (with-lock-held ((down-lock self))
       (when (plusp (length buffer))
+        (format-log "~&down-layer sends buffer:    ~S~%"
+                    buffer)
         (write-sequence buffer stream)
         (setf (fill-pointer buffer) 0))
       (setf (%writingp self) nil))))
@@ -478,7 +518,7 @@ we may decode them from the input-buffer.
             :input-buffering (stream-input-buffering stream)
             :output-buffering (stream-output-buffering stream)
             :echo-mode (stream-echo-mode stream)
-            :length-input-buffer (length (input-buffer stream))
+            :length-input-buffer (%input-buffer-length (input-buffer stream))
             :length-output-buffer (length (output-buffer stream))))
   stream)

@@ -618,6 +658,22 @@ we may decode them from the input-buffer.
   (head 0)
   (tail 0))

+(defmethod print-object ((buffer input-buffer) stream)
+  (print-unreadable-object (buffer stream :identity t :type t)
+    (format stream ":LENGTH ~A :CONTENTS ~S"
+            (%input-buffer-length buffer)
+            (if (<= (input-buffer-head buffer)
+                    (input-buffer-tail buffer))
+                (subseq (input-buffer-data buffer)
+                        (input-buffer-head buffer)
+                        (input-buffer-tail buffer))
+                (concatenate '(vector octet)
+                             (subseq (input-buffer-data buffer)
+                                     (input-buffer-tail buffer))
+                             (subseq (input-buffer-data buffer)
+                                     0
+                                     (input-buffer-head buffer)))))))
+
 (defun make-input-buffer (buffering)
   (let* ((size (if (integerp buffering)
                    buffering
@@ -626,17 +682,15 @@ we may decode them from the input-buffer.
     (setf (fill-pointer buffer) size)
     (%make-input-buffer :data buffer)))

-(defun %input-buffer-free-space (stream)
-  (let* ((buffer (input-buffer stream))
-         (size   (length (input-buffer-data buffer))))
+(defun %input-buffer-free-space (buffer)
+  (let ((size   (length (input-buffer-data buffer))))
     (- size 1 (mod (- (input-buffer-tail buffer)
                       (input-buffer-head buffer))
                    size))))
 (declaim (inline %input-buffer-free-space))

-(defun %input-buffer-length (stream)
-  (let* ((buffer (input-buffer stream))
-         (size   (length (input-buffer-data buffer))))
+(defun %input-buffer-length (buffer)
+  (let ((size   (length (input-buffer-data buffer))))
     (mod (- (input-buffer-tail buffer)
             (input-buffer-head buffer))
          size)))
@@ -653,30 +707,41 @@ we may decode them from the input-buffer.

 (defun %wait-for-input-free-space (stream required)
   (loop
-      :while (< (%input-buffer-free-space stream) required)
+      :while (< (%input-buffer-free-space (input-buffer stream)) required)
       :do (condition-wait (for-input-free-space stream) (stream-lock stream))))
 (declaim (inline %wait-for-input-free-space))

 (defun %wait-for-input-data-present (stream required)
   (loop
-    :while (< (%input-buffer-length stream) required)
+    :while (< (%input-buffer-length (input-buffer stream)) required)
     :do (condition-wait (for-input-data-present stream) (stream-lock stream))))
 (declaim (inline %wait-for-input-data-present))

+(defun %%input-buffer-fetch-octet (stream)
+  (%wait-for-input-data-present stream 1)
+  (let* ((buffer (input-buffer stream))
+         (data   (input-buffer-data buffer))
+         (head   (input-buffer-head buffer))
+         (octet  (aref data head)))
+    (setf (input-buffer-head buffer) (mod (+ head 1) (length data)))
+    (condition-notify (for-input-free-space stream))
+    octet))
+
+(defmethod %input-buffer-fetch-octet ((stream telnet-stream) nohang)
+  ;; Assume (stream-lock stream) is already held.
+  ;;    then read the octet and convert it to character
+  ;;    else (%wait-for-input-data-present)
+  (if (and nohang (zerop (%input-buffer-length (input-buffer stream))))
+      nil
+      (%%input-buffer-fetch-octet stream)))
+
 (defmethod input-buffer-fetch-octet ((stream telnet-stream) nohang)
   ;;    then read the octet and convert it to character
   ;;    else (%wait-for-input-data-present)
-  (if (and nohang (zerop (%input-buffer-length stream)))
+  (if (and nohang (zerop (%input-buffer-length (input-buffer stream))))
       nil
       (with-lock-held ((stream-lock stream))
-        (%wait-for-input-data-present stream 1)
-        (let* ((buffer (input-buffer stream))
-               (data   (input-buffer-data buffer))
-               (head   (input-buffer-head buffer))
-               (octet  (aref data head)))
-          (setf (input-buffer-head buffer) (mod (+ head 1) (length data)))
-          (condition-notify (for-input-free-space stream))
-          octet))))
+        (%%input-buffer-fetch-octet stream))))

 (defmethod input-buffer-append-octet ((stream telnet-stream) octet)
   (with-lock-held ((stream-lock stream))
@@ -702,8 +767,8 @@ we may decode them from the input-buffer.
             (let ((start2 (nth-value 1 (replace-ascii-bytes data text :newline :crlf :start1 s1 :end1 e1 :start2 0 :end2 end))))
               (when s2
                 (replace-ascii-bytes data text :newline :crlf :start1 s2 :end1 e2 :start2 start2 :end2 end)))
-            (setf (input-buffer-tail buffer) nt)))
-        (condition-notify (for-input-data-present stream))))))
+            (setf (input-buffer-tail buffer) nt))))
+      (condition-notify (for-input-data-present stream)))))

 (defmethod input-buffer-append-octets ((stream telnet-stream) octets start end)
   (let ((len (- (or end (length octets)) start)))
@@ -717,15 +782,15 @@ we may decode them from the input-buffer.
             (replace data octets :start1 s1 :end1 e1 :start2 start :end2 (- e1 s1))
             (when s2
               (replace data octets :start1 s2 :end1 e2 :start2 (+ start (- e1 s1)) :end2 end))
-            (setf (input-buffer-tail buffer) nt)))
-        (condition-notify (for-input-data-present stream))))))
+            (setf (input-buffer-tail buffer) nt))))
+      (condition-notify (for-input-data-present stream)))))

 (defmethod input-buffer-erase-character ((stream telnet-stream))
   (with-lock-held ((stream-lock stream))
     (let* ((buffer (input-buffer stream))
            (data   (input-buffer-data buffer))
            (tail   (input-buffer-tail buffer)))
-      (when (plusp (%input-buffer-length stream))
+      (when (plusp (%input-buffer-length buffer))
         (let ((last (mod (- tail 1) (length data))))
           (unless (or (= (aref data last) lf)
                       (= (aref data last) cr))
@@ -739,7 +804,7 @@ we may decode them from the input-buffer.
            (head   (input-buffer-head buffer))
            (tail   (input-buffer-tail buffer))
            (size   (length data)))
-      (when (plusp (%input-buffer-length stream))
+      (when (plusp (%input-buffer-length buffer))
         (loop
           :with last := (mod (- tail 1) size)
           :while (and (/= (aref data last) lf)
@@ -754,7 +819,7 @@ we may decode them from the input-buffer.
     (let* ((buffer (input-buffer stream))
            (data   (input-buffer-data buffer))
            (head   (input-buffer-head buffer)))
-      (when (plusp (%input-buffer-length stream))
+      (when (plusp (%input-buffer-length buffer))
         (aref data head)))))

 (defmethod input-buffer-read-octet ((stream telnet-stream))
@@ -800,6 +865,7 @@ we may decode them from the input-buffer.
   ;; BYTE:       a VECTOR of (UNSIGNED-BYTE 8).
   ;; START, END: bounding index designators of sequence.
   ;;             The defaults are for START 0 and for END nil.
+  (format-log "~&up-layer receive binary: ~S~%" (subseq bytes start end))
   (input-buffer-append-octets up-sender bytes start (or end (length bytes))))

 (defmethod receive-text    ((up-sender telnet-stream) (text string) &key (start 0) end)
@@ -807,11 +873,13 @@ we may decode them from the input-buffer.
   ;; TEXT: a string containing only printable ASCII characters and #\newline.
   (assert (zerop start))
   (assert (null end))
+  (format-log "~&up-layer receive text: ~S~%" (subseq text start end))
   (input-buffer-append-text up-sender text))

 (defmethod receive-text    ((up-sender telnet-stream) (text vector) &key (start 0) end)
   ;; Receive some ASCII text
   ;; TEXT: a string containing only printable ASCII characters and #\newline.
+  (format-log "~&up-layer receive text: ~S~%" (subseq text start end))
   (input-buffer-append-octets up-sender text start end))

 (defmethod receive-control ((up-sender telnet-stream) control)
@@ -820,6 +888,7 @@ we may decode them from the input-buffer.
   ;;                  :erase-line :erase-character
   ;;                  :break :cr :ff :vt :lf :ht :bs :bel :nul
   ;;                  :end-of-record).
+  (format-log "~&up-layer receive control: ~S~%" control)
   (case control
     ;; | Controls          | I/O        | Description                                      |
     ;; |-------------------+------------+--------------------------------------------------|
@@ -915,7 +984,7 @@ we may decode them from the input-buffer.
                        (babel::get-character-encoding
                         encoding)))
                  ;; 1-octet encoding:
-                 (let ((code (input-buffer-fetch-octet stream no-hang)))
+                 (let ((code (%input-buffer-fetch-octet stream no-hang)))
                    (when code
                      (let* ((octets (make-array 1 :element-type '(unsigned-byte 8) :initial-element code))
                             (char   (decode-character octets :encoding encoding)))
@@ -926,7 +995,7 @@ we may decode them from the input-buffer.
                  (loop
                    :named read
                    :with partial := (partial-character-octets stream)
-                   :for code := (input-buffer-fetch-octet stream no-hang)
+                   :for code := (%input-buffer-fetch-octet stream no-hang)
                    :while code
                    :do (vector-push-extend code partial (length partial))
                        (multiple-value-bind (char validp size)
@@ -1031,6 +1100,16 @@ we may decode them from the input-buffer.
 ;;                  :break :cr :ff :vt :lf :ht :bs :bel :nul
 ;;                  :end-of-record)."))

+(defmethod send-binary :before (nvt bytes)
+  (declare (ignorable nvt))
+  (format-log "~&up-layer sends binary:           ~S~%" bytes))
+(defmethod send-text :before (nvt bytes)
+  (declare (ignorable nvt))
+  (format-log "~&up-layer sends text:             ~S~%" bytes))
+(defmethod send-control :before (nvt bytes)
+  (declare (ignorable nvt))
+  (format-log "~&up-layer sends control:          ~S~%" bytes))
+
 ;;; character output

 (defun flush-output-buffer (stream)
@@ -1043,45 +1122,44 @@ we may decode them from the input-buffer.

 (defmethod stream-write-char ((stream telnet-stream) char)
   (check-stream-open stream 'stream-write-char)
-  (with-lock-held ((stream-lock stream))
+  (unless (char= #\newline char)
+    (let ((code (char-code char)))
+      (when (or (<= 0 code 31) (<= 127 code))
+        (stream-write-string stream (format nil "^~C" (code-char (mod (+ code 64) 128))))
+        (return-from stream-write-char))))
+  (with-lock-held ((stream-lock stream)) ;; <<<<<<<<< WE'RE SAFE !
     (let ((encoding  (stream-external-format stream))
           (buffering (stream-output-buffering stream)))
       (case buffering

         (:character                     ; no buffering
-
-         ;; If we have something in the buffer flush it now.
-         (flush-output-buffer stream)
-
          (cond
            ((char= #\newline char)
+            (flush-output-buffer stream)
             (send-control (nvt stream) :cr)
             (send-control (nvt stream) :lf))
            ((eq encoding :us-ascii)
-            (send-text (nvt stream) (string char)))
+            (vector-push (ascii-code char) (output-buffer stream))
+            (flush-output-buffer stream))
            (t
-            (send-binary (nvt stream)
-                         (string-to-octets (string char)
-                                           :encoding encoding)))))
+            (encode-string-to-output-buffer stream (string char))
+            (flush-output-buffer stream))))

         (:line                          ; line buffering
          (cond
            ((char= #\newline char) ; if newline, flush the buffer now.
+            ;; flush only on newline
             (flush-output-buffer stream)
+            ;; TODO: check whether sending CR LF is equivalent to send-control :cr :lf
+            ;; TODO: can we buffer the :cr :lf control with the line? Is it done in the NVT?
             (send-control (nvt stream) :cr)
             (send-control (nvt stream) :lf))
            ((eq encoding :us-ascii)
             (let ((buffer (output-buffer stream)))
-              (vector-push-extend char buffer (length buffer)))
-            (send-text (nvt stream) (string char)))
+              (vector-push-extend (ascii-code char) buffer (length buffer))))
            (t
-            (let* ((buffer (output-buffer stream))
-                   (start (fill-pointer buffer)))
-              (setf (fill-pointer buffer) (array-dimension buffer 0))
-              (setf (fill-pointer buffer)
-                    (nth-value 1 (replace-octets-by-string buffer (string char)
-                                                           :start1 start
-                                                           :encoding encoding)))))))
+            (encode-string-to-output-buffer stream (string char)))))
+
         (otherwise
          (assert (integerp buffering))
          (cond
@@ -1089,23 +1167,15 @@ we may decode them from the input-buffer.
             (let ((buffer (output-buffer stream)))
               (if (char= #\newline char)
                   (progn
-                    (vector-push-extend #\return   buffer (length buffer))
-                    (vector-push-extend #\linefeed buffer (length buffer)))
-                  (vector-push-extend char buffer (length buffer)))
-              (when (<= buffering (length buffer))
-                (send-text (nvt stream) buffer)
-                (setf (fill-pointer buffer) 0))))
+                    ;; TODO: check whether sending CR LF is equivalent to send-control :cr :lf
+                    (vector-push-extend CR buffer (length buffer))
+                    (vector-push-extend LF buffer (length buffer)))
+                  (vector-push-extend (ascii-code char) buffer (length buffer)))))
            (t
-            (let* ((buffer (output-buffer stream))
-                   (start (fill-pointer buffer)))
-              (setf (fill-pointer buffer) (array-dimension buffer 0))
-              (setf (fill-pointer buffer)
-                    (nth-value 1 (replace-octets-by-string buffer (string char)
-                                                           :start1 start
-                                                           :encoding encoding)))
-              (when (<= buffering (length buffer))
-                (send-binary (nvt stream) buffer)
-                (setf (fill-pointer buffer) 0)))))))
+            (encode-string-to-output-buffer stream (string char))))
+         (when (<= buffering (length (output-buffer stream)))
+           ;; flush only on buffer full
+           (flush-output-buffer stream))))

       (if (char= #\newline char)
           (setf (column stream) 0)
@@ -1118,9 +1188,8 @@ we may decode them from the input-buffer.
   nil)


-(defgeneric encode-string-to-output-buffer (stream string &key start end))
+(defgeneric encode-string-to-output-buffer (stream string &key start  end))
 (defmethod encode-string-to-output-buffer ((stream telnet-stream) string &key (start 0) end)
-  ;; STRING doesn't contain #\newline
   (let* ((encoding (stream-external-format stream))
          (buffer   (output-buffer stream))
          (start1   (fill-pointer buffer)))
@@ -1150,23 +1219,28 @@ we may decode them from the input-buffer.
         (vnewlines    (gensym))
         (process-line (gensym))
         (vstart       (gensym))
-        (vend         (gensym)))
+        (vend         (gensym))
+        (vsstart      (gensym))
+        (vsend        (gensym)))
     `(let* ((,vstring    ,string-expression)
-            (,vnewlines  (positions #\newline ,vstring :start ,start-expr :end ,end-expr)))
+            (,vsstart    ,start-expr)
+            (,vsend      ,end-expr)
+            (,vnewlines  (positions #\newline ,vstring :start ,vsstart :end ,vsend)))
        (flet ((,process-line (start end)
                 (let ((,line-var ,vstring)
                       (,start-var start)
                       (,end-var end))
                   ,line-expression)))
          (loop
-           :for ,vstart := 0 :then (1+ ,vend)
+           :for ,vstart := ,vsstart :then (1+ ,vend)
            :for ,vend :in ,vnewlines
            :do (progn
                  (when (< ,vstart ,vend)
                    (,process-line ,vstart ,vend))
                  ,@newline-body)
            :finally (when (< ,vstart (length ,vstring))
-                      (,process-line ,vstart (length ,vstring))))))))
+                      (,process-line ,vstart ,vsend)))))))
+

 (defmethod stream-write-string ((stream telnet-stream) string &optional (start 0) end)
   (check-stream-open stream 'stream-write-string)
@@ -1175,7 +1249,7 @@ we may decode them from the input-buffer.
       ;; If we have something in the buffer flush it now.
       (flush-output-buffer stream)
       (for-each-line ((line lstart lend) (string start end))
-                     (encode-string-to-output-buffer stream line lstart lend)
+                     (encode-string-to-output-buffer stream line :start lstart :end lend)
         (flush-output-buffer stream)
         (send-control (nvt stream) :cr)
         (send-control (nvt stream) :lf))
diff --git a/clext/telnet/test-stub-nvt.lisp b/clext/telnet/test-stub-nvt.lisp
new file mode 100644
index 0000000..ddc14a4
--- /dev/null
+++ b/clext/telnet/test-stub-nvt.lisp
@@ -0,0 +1,101 @@
+(defpackage "COM.INFORMATIMAGO.CLEXT.TELNET.TEST.STUB-NVT"
+  (:use "COMMON-LISP"
+        "COM.INFORMATIMAGO.COMMON-LISP.TELNET")
+  (:export "STUB-NVT"))
+(in-package "COM.INFORMATIMAGO.CLEXT.TELNET.TEST.STUB-NVT")
+
+(defclass stub-nvt ()
+  ((urgent-mode-p  :initform nil
+                   :accessor urgent-mode-p
+                   :reader nvt-urgent-mode-p
+                   :documentation "Urgent mode: we've received an urgent notification
+and are discarding text bytes till the next IAC DM.")
+   (ascii-decoder-enabled-p :initform t
+                            :accessor ascii-decoder-enabled-p
+                            :documentation "Whether received text messages are decoded from ASCII.")))
+
+(defmethod initialize-instance :before ((nvt stub-nvt) &key &allow-other-keys))
+
+(defmethod send-binary  ((nvt stub-nvt) bytes)
+  (format *trace-output* "~&~S ~S ~S~%"
+          'stub-nvt 'send-binary bytes))
+
+(defmethod send-text    ((nvt stub-nvt) text)
+  (format *trace-output* "~&~S ~S ~S~%"
+          'stub-nvt 'send-text text))
+
+(defmethod send-control ((nvt stub-nvt) control)
+  (format *trace-output* "~&~S ~S ~S~%"
+          'stub-nvt 'send-control control))
+
+(defmethod ascii-decoder-enabled-p :before ((nvt stub-nvt))
+  (format *trace-output* "~&~S ~S -> ~S~%"
+          'stub-nvt 'ascii-decoder-enabled-p (slot-value nvt 'ascii-decoder-enable-p)))
+
+(defmethod (setf ascii-decoder-enabled-p) :before (flag (nvt stub-nvt))
+  (format *trace-output* "~&~S ~S ~S~%"
+          'stub-nvt '(setf ascii-decoder-enabled-p) flag))
+
+
+(defmethod receive ((nvt stub-nvt) bytes &key start end)
+  (format *trace-output* "~&~S ~S ~S :start ~S :end ~S~%"
+          'stub-nvt 'receive bytes start end))
+
+
+;; ;; option control:
+;;
+;; (defmethod option-enabled-p ((nvt stub-nvt) option-name &optional who)
+;;   (:documentation "Whether the option is currently enabled,
+;; if WHO is nil, then for either end, otherwise for the indicated end.
+;; OPTION-NAME: a keyword or fixnum  denoting the option.
+;; WHO:         (member nil :us :him)."))
+;;
+;; (defmethod option-negotiating-p ((nvt stub-nvt) option-name &optional who)
+;;   (:documentation "Whether the option is currently being negotiated,
+;; if WHO is nil, then for either end, otherwise for the indicated end.
+;; OPTION-NAME: a keyword or fixnum  denoting the option.
+;; WHO:         (member nil :us :him)."))
+;;
+;; (defmethod enable-option    ((nvt stub-nvt) option-name &optional who)
+;;   (:documentation "Initiate the negotiation to enable the option.
+;; OPTION-NAME: a keyword or fixnum  denoting the option.
+;; WHO:         (member nil :us :him)."))
+;;
+;; (defmethod disable-option   ((nvt stub-nvt) option-name &optional who)
+;;   (:documentation "Initiate the negotiation to disable the option.
+;; OPTION-NAME: a keyword or fixnum  denoting the option.
+;; WHO:         (member nil :us :him)."))
+;;
+;;
+;; (defun (setf option-enabled-p) (flag (nvt stub-nvt) option-name &optional who)
+;;   "Enable or disable the option according to the boolean FLAG.
+;; OPTION-NAME: a keyword or fixnum denoting an option."
+;;   (if flag
+;;       (enable-option  (nvt stub-nvt) option-name who)
+;;       (disable-option (nvt stub-nvt) option-name who)))
+;;
+;;
+;;
+;; (defmethod option-register-class ((nvt stub-nvt) option-name option-class)
+;;   (:documentation "Register OPTION-CLASS as the class for a given OPTION-NAME.
+;; NOTE:         If the option is already initialized with a different
+;;               class, then CHANGE-CLASS is called on the instance.
+;; OPTION-NAME:  a keyword or fixnum denoting an option.
+;; OPTION-CLASS: a class designator, should be a subclass of OPTION."))
+;;
+;;
+;; (defmethod option-register-default-classes ((nvt stub-nvt) option-names)
+;;   (:documentation "Register the default option-classes for the option given in OPTION-NAMES.
+;; NOTE:         If the option is already initialized with a different
+;;               class, then CHANGE-CLASS is called on the instance.
+;; OPTION-NAMES: a list of keyword or fixnum denoting options.
+;; RETURN:       The subset of OPTION-NAMES (codes are converted into
+;;               option-names) for which a specific default class
+;;               exists."))
+;;
+;;
+;; ;; Implemented by subclasses of OPTION:
+;;
+;; (defmethod receive-subnegotiation (option (nvt stub-nvt) bytes &key start end)
+;;   (:documentation "Processes the subnegotiation packet (subseq bytes start end)
+;; starting with IAC SB and ending with IAC SE."))
ViewGit