;;; std/stream.lisp --- Standard Streams

 ;;

 ;;; Code:

 (in-package :std/stream)

 (defun copy-stream (input output &key (element-type (stream-element-type input))

                     (buffer-size 4096)

                     (buffer (make-array buffer-size :element-type element-type))

                     (start 0) end

                     finish-output)

   "Reads data from INPUT and writes it to OUTPUT. Both INPUT and OUTPUT must

 be streams, they will be passed to READ-SEQUENCE and WRITE-SEQUENCE and must have

 compatible element-types."

   (check-type start non-negative-integer)

   (check-type end (or null non-negative-integer))

   (check-type buffer-size positive-integer)

   (when (and end

              (< end start))

     (error "END is smaller than START in ~S" 'copy-stream))

   (let ((output-position 0)

         (input-position 0))

     (unless (zerop start)

       ;; FIXME add platform specific optimization to skip seekable streams

       (loop while (< input-position start)

             do (let ((n (read-sequence buffer input

                                        :end (min (length buffer)

                                                  (- start input-position)))))

                  (when (zerop n)

                    (error "~@<Could not read enough bytes from the input to fulfill ~

                            the :START ~S requirement in ~S.~:@>" 'copy-stream start))

                  (incf input-position n))))

     (assert (= input-position start))

     (loop while (or (null end) (< input-position end))

           do (let ((n (read-sequence buffer input

                                      :end (when end

                                             (min (length buffer)

                                                  (- end input-position))))))

                (when (zerop n)

                  (if end

                      (error "~@<Could not read enough bytes from the input to fulfill ~

                           the :END ~S requirement in ~S.~:@>" 'copy-stream end)

                      (return)))

                (write-sequence buffer output :end n)

     (when finish-output

       (finish-output output))

     output-position))

 ;; from SBCL manual

 ;;; Wrapped Streams

 (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)))

 #| example:

 (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]

 |#

 (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)))

 (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))))

 #| example:

 (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

 |#

 (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)))