source: cl-darcs/trunk/unreadable-stream.lisp

;;; Copyright (C) 2006 Magnus Henoch
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; published by the Free Software Foundation; either version 2 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
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA

(in-package :darcs)

(defclass unreadable-stream
    (trivial-gray-streams:trivial-gray-stream-mixin
     trivial-gray-streams:fundamental-binary-input-stream)
  ((stream
    :initarg :base-stream
    :documentation "The stream wrapped by this unreadable-stream.")
   (haskellish-lines
    :initarg :haskellish-lines :initform nil
    :documentation "If true, read lines as Haskell would read them.
That is, a line is a (possibly empty) list of characters delimited
by either newlines or end-of-file.  In particular, if the file ends
with a newline, it has an extra empty last line in Haskell mode.

This flag affects only `read-binary-line'.")
   
   (buffer :initform nil)
   (at-end-of-file :initform nil))
  (:documentation "A wrapper for a binary input stream.
Unlimited \"unreading\" is allowed through UNREAD-BYTE and
UNREAD-SEQUENCE."))

(defmethod trivial-gray-streams:stream-read-byte
    ((stream unreadable-stream))
  (with-slots ((base-stream stream) buffer) stream
    (let ((from-buffer (car buffer)))
      ;; Has something been unread?
      (cond
        ;; No, nothing.
        ((null from-buffer)
         (read-byte base-stream nil :eof))
        ;; A single byte.
        ((numberp from-buffer)
         (pop buffer)
         from-buffer)
        ;; A sequence.
        ((listp from-buffer)
         ;; Get the byte from the indicated start index.
         (prog1
             (elt (third from-buffer) (first from-buffer))
           (incf (first from-buffer))
           ;; If the sequence is exhausted, drop it.
           (when (= (first from-buffer) (second from-buffer))
             ;; Wait - is there a terminating newline?
             (if (eql (fourth from-buffer) :line)
                 ;; Preserve it.
                 (setf (car buffer) 10)
                 (pop buffer)))))
        ;; Something else.
        (t
         (error "Invalid buffer entry ~S." from-buffer))))))

(defmethod trivial-gray-streams:stream-read-sequence
    ((stream unreadable-stream)
     sequence start end &key)
  (with-slots ((base-stream stream) buffer) stream
    (unless start (setf start 0))
    (unless end (setf end (length sequence)))
    
    ;; First, see if we can use the buffer.
    (loop while (and (< start end) buffer)
       do (let ((from-buffer (car buffer)))
            ;; What do we find in the buffer?
            (cond
              ;; A single byte.
              ((numberp from-buffer)
               (setf (elt sequence start) from-buffer)
               (incf start)
               (pop buffer))
              ;; A sequence.
              ((listp from-buffer)
               (let* ((has-newline (eql (fourth from-buffer) :line))
                      (len (min (- end start) 
                                (- (second from-buffer) (first from-buffer)))))
                 (setf (subseq sequence start (+ start len))
                       (subseq (third from-buffer) (+ (first from-buffer) len)))
                 (incf start len)
                 (incf (first from-buffer) len)
                 ;; If the sequence is exhausted, drop it.
                 (when (= (first from-buffer) (second from-buffer))
                   (if (not has-newline)
                       (pop buffer)
                       ;; Is there space for the newline?
                       (if (< start end)
                           ;; Yes - line is entirely consumed.
                           (progn
                             (setf (elt sequence start) 10)
                             (incf start)
                             (pop buffer))
                           ;; No - preserve the newline.
                           (setf (car buffer) 10)))))))))

    ;; If we need more data, get it from the base stream.
    (if (< start end)
        (read-sequence sequence base-stream :start start :end end)
        ;; Otherwise, report that the sequence is full.
        end)))

(defmethod read-binary-line ((stream unreadable-stream) &optional (eof-error-p t) eof-value)
  "If stream is in \"Haskell mode\", treat newlines at end of file accordingly."
  (if (not (slot-value stream 'haskellish-lines))
      (call-next-method)
      ;; The delimiter between lines is a newline or end-of-file.
      ;; Thus, if we have just returned the last newline-terminated
      ;; line and stand before EOF, we can't just return EOF since
      ;; there is an zero-length line between the last newline and the
      ;; EOF.
      (if (null (slot-value stream 'at-end-of-file))
          ;; So we haven't read EOF yet.  That means that we can
          ;; return at least one more line (though it may be
          ;; zero-length).
          (multiple-value-bind (line delim)
              (read-until 10 stream nil :eof)
            ;; If EOF follows after that line, note it.
            (when (eql delim :eof)
              (setf (slot-value stream 'at-end-of-file) t))
            line)
          ;; If we have already set the EOF flag, act accordingly.
          (if eof-error-p
              (error 'end-of-file :stream stream)
              eof-value))))

;; This method is meant as an optimization, but it actually makes
;; things slower.  Need to investigate why...
#+nil 
(defmethod read-binary-line :around ((stream unreadable-stream) &optional (eof-error-p t) eof-value)
  "If possible, return a recently unread line."
  ;; If a line has been unread, we just return it.
  (with-slots (buffer) stream
    (let ((buffer-entry (car buffer)))
      (if (and (listp buffer-entry) (eql (fourth buffer-entry) :line))
          ;; Yes!
          (let ((start (first buffer-entry))
                (end (second buffer-entry))
                (sequence (third buffer-entry)))
            (pop buffer)
            ;; Simple case: it's a vector, and we haven't begun nibbling at it.
            (if (and (vectorp sequence) (= start 0))
                sequence
                ;; Otherwise, make a new vector.
                (make-array (- end start) :element-type '(unsigned-byte 8)
                            :initial-contents (subseq sequence start))))
          ;; Oh well...
          (call-next-method)))))

(defmethod close ((stream unreadable-stream) &key abort)
  "Close the underlying stream of STREAM."
  (close (slot-value stream 'stream) :abort abort)
  (call-next-method))

(defmethod unread-byte ((stream unreadable-stream) byte)
  "Store BYTE at the head of the unread buffer."
  (setf (slot-value stream 'at-end-of-file) nil)
  (push byte (slot-value stream 'buffer)))

(defmethod unread-sequence ((stream unreadable-stream) sequence)
  "Store SEQUENCE at the head of the unread buffer.
It is assumed that SEQUENCE will not be modified."
  (setf (slot-value stream 'at-end-of-file) nil)
  (with-slots (buffer) stream
    ;; Empty sequences must not be stored in the buffer.
    (unless (zerop (length sequence))
      (push (list 0 (length sequence) sequence) buffer))))

(defmethod unread-line ((stream unreadable-stream) line)
  "Store LINE with an appended newline at the head of the unread buffer.
It is assumed that SEQUENCE will not be modified."
  (setf (slot-value stream 'at-end-of-file) nil)
  (with-slots (buffer) stream
    ;; If the line is empty, just store a newline.
    (if (zerop (length line))
        (push 10 buffer)
        (push (list 0 (length line) line :line) buffer))))

(defmethod print-object ((object unreadable-stream) stream)
  (print-unreadable-object (object stream :type t)
    (format stream "~A ~A" (slot-value object 'buffer) (slot-value object 'stream))))