Sbcl stream exqmples

Stream-examples.lisp

     (defclass wrapped-stream (fundamental-stream)
       ((stream :initarg :stream :reader stream-of)))
     
     (defmethod stream-element-type ((stream wrapped-stream))
       (stream-element-type (stream-of stream)))
     
     (defmethod close ((stream wrapped-stream) &key abort)
       (close (stream-of stream) :abort abort))
     
     (defclass wrapped-character-input-stream
         (wrapped-stream fundamental-character-input-stream)
       ())
     
     (defmethod stream-read-char ((stream wrapped-character-input-stream))
       (read-char (stream-of stream) nil :eof))
     
     (defmethod stream-unread-char ((stream wrapped-character-input-stream)
                                    char)
       (unread-char char (stream-of stream)))
     
     (defclass counting-character-input-stream
         (wrapped-character-input-stream)
       ((char-count :initform 1 :accessor char-count-of)
        (line-count :initform 1 :accessor line-count-of)
        (col-count :initform 1 :accessor col-count-of)
        (prev-col-count :initform 1 :accessor prev-col-count-of)))
     
     (defmethod stream-read-char ((stream counting-character-input-stream))
       (with-accessors ((inner-stream stream-of) (chars char-count-of)
                        (lines line-count-of) (cols col-count-of)
                        (prev prev-col-count-of)) stream
           (let ((char (call-next-method)))
             (cond ((eql char :eof)
                    :eof)
                   ((char= char #\Newline)
                    (incf lines)
                    (incf chars)
                    (setf prev cols)
                    (setf cols 1)
                    char)
                   (t
                    (incf chars)
                    (incf cols)
                    char)))))
     
     (defmethod stream-unread-char ((stream counting-character-input-stream)
                                    char)
       (with-accessors ((inner-stream stream-of) (chars char-count-of)
                        (lines line-count-of) (cols col-count-of)
                        (prev prev-col-count-of)) stream
           (cond ((char= char #\Newline)
                  (decf lines)
                  (decf chars)
                  (setf cols prev))
                 (t
                  (decf chars)
                  (decf cols)
                  char))
           (call-next-method)))


;; The default methods for stream-read-char-no-hang, stream-peek-char, stream-listen, stream-clear-input, stream-read-line, and stream-read-sequence ;; should be sufficient (though the last two will probably be slower than methods that forwarded directly).

;; Here's a sample use of this class:

     (with-input-from-string (input "1 2
      3 :foo  ")
       (let ((counted-stream (make-instance 'counting-character-input-stream
                              :stream input)))
         (loop for thing = (read counted-stream) while thing
            unless (numberp thing) do
              (error "Non-number ~S (line ~D, column ~D)" thing
                     (line-count-of counted-stream)
                     (- (col-count-of counted-stream)
                        (length (format nil "~S" thing))))
            end
            do (print thing))))
     1 
     2 
     3
     Non-number :FOO (line 2, column 5)
       [Condition of type SIMPLE-ERROR]

;; 10.3.8.2 Output prefixing character stream

;; One use for a wrapped output stream might be to prefix each line of text with a timestamp, e.g., for a logging stream. Here's a simple stream that does ;; this, though without any fancy line-wrapping. Note that all character output stream classes must implement stream-write-char and stream-line-column.

     (defclass wrapped-stream (fundamental-stream)
       ((stream :initarg :stream :reader stream-of)))
     
     (defmethod stream-element-type ((stream wrapped-stream))
       (stream-element-type (stream-of stream)))
     
     (defmethod close ((stream wrapped-stream) &key abort)
       (close (stream-of stream) :abort abort))
     
     (defclass wrapped-character-output-stream
         (wrapped-stream fundamental-character-output-stream)
       ((col-index :initform 0 :accessor col-index-of)))
     
     (defmethod stream-line-column ((stream wrapped-character-output-stream))
       (col-index-of stream))
     
     (defmethod stream-write-char ((stream wrapped-character-output-stream)
                                   char)
       (with-accessors ((inner-stream stream-of) (cols col-index-of)) stream
         (write-char char inner-stream)
         (if (char= char #\Newline)
             (setf cols 0)
             (incf cols))))
     
     (defclass prefixed-character-output-stream
         (wrapped-character-output-stream)
       ((prefix :initarg :prefix :reader prefix-of)))
     
     (defgeneric write-prefix (prefix stream)
       (:method ((prefix string) stream) (write-string prefix stream))
       (:method ((prefix function) stream) (funcall prefix stream)))
     
     (defmethod stream-write-char ((stream prefixed-character-output-stream)
                                   char)
       (with-accessors ((inner-stream stream-of) (cols col-index-of)
                        (prefix prefix-of)) stream
         (when (zerop cols)
           (write-prefix prefix inner-stream))
         (call-next-method)))

;; As with the example input stream, this implements only the minimal protocol. A production implementation should also provide methods for at least ;; 
;; stream-write-line, stream-write-sequence. And here's a sample use of this class:

     (flet ((format-timestamp (stream)
              (apply #'format stream "[~2@*~2,' D:~1@*~2,'0D:~0@*~2,'0D] "
                     (multiple-value-list (get-decoded-time)))))
       (let ((output (make-instance 'prefixed-character-output-stream
                                    :stream *standard-output*
                                    :prefix #'format-timestamp)))
         (loop for string in '("abc" "def" "ghi") do
              (write-line string output)
              (sleep 1))))

;;     [ 0:30:05] abc
  ;;   [ 0:30:06] def
;;     [ 0:30:07] ghi
  ;;   NIL