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

Last change on this file was 58, checked in by Magnus Henoch, 16 years ago

Use print-unreadable-object.

File size: 7.3 KB
Line 
1;;; Copyright (C) 2006 Magnus Henoch
2;;;
3;;; This program is free software; you can redistribute it and/or
4;;; modify it under the terms of the GNU General Public License as
5;;; published by the Free Software Foundation; either version 2 of the
6;;; License, or (at your option) any later version.
7;;;
8;;; This program is distributed in the hope that it will be useful,
9;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
10;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
11;;; General Public License for more details.
12;;;
13;;; You should have received a copy of the GNU General Public License
14;;; along with this program; if not, write to the Free Software
15;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
16
17(in-package :darcs)
18
19(defclass unreadable-stream
20    (trivial-gray-streams:trivial-gray-stream-mixin
21     trivial-gray-streams:fundamental-binary-input-stream)
22  ((stream
23    :initarg :base-stream
24    :documentation "The stream wrapped by this unreadable-stream.")
25   (haskellish-lines
26    :initarg :haskellish-lines :initform nil
27    :documentation "If true, read lines as Haskell would read them.
28That is, a line is a (possibly empty) list of characters delimited
29by either newlines or end-of-file.  In particular, if the file ends
30with a newline, it has an extra empty last line in Haskell mode.
31
32This flag affects only `read-binary-line'.")
33   
34   (buffer :initform nil)
35   (at-end-of-file :initform nil))
36  (:documentation "A wrapper for a binary input stream.
37Unlimited \"unreading\" is allowed through UNREAD-BYTE and
38UNREAD-SEQUENCE."))
39
40(defmethod trivial-gray-streams:stream-read-byte
41    ((stream unreadable-stream))
42  (with-slots ((base-stream stream) buffer) stream
43    (let ((from-buffer (car buffer)))
44      ;; Has something been unread?
45      (cond
46        ;; No, nothing.
47        ((null from-buffer)
48         (read-byte base-stream nil :eof))
49        ;; A single byte.
50        ((numberp from-buffer)
51         (pop buffer)
52         from-buffer)
53        ;; A sequence.
54        ((listp from-buffer)
55         ;; Get the byte from the indicated start index.
56         (prog1
57             (elt (third from-buffer) (first from-buffer))
58           (incf (first from-buffer))
59           ;; If the sequence is exhausted, drop it.
60           (when (= (first from-buffer) (second from-buffer))
61             ;; Wait - is there a terminating newline?
62             (if (eql (fourth from-buffer) :line)
63                 ;; Preserve it.
64                 (setf (car buffer) 10)
65                 (pop buffer)))))
66        ;; Something else.
67        (t
68         (error "Invalid buffer entry ~S." from-buffer))))))
69
70(defmethod trivial-gray-streams:stream-read-sequence
71    ((stream unreadable-stream)
72     sequence start end &key)
73  (with-slots ((base-stream stream) buffer) stream
74    (unless start (setf start 0))
75    (unless end (setf end (length sequence)))
76   
77    ;; First, see if we can use the buffer.
78    (loop while (and (< start end) buffer)
79       do (let ((from-buffer (car buffer)))
80            ;; What do we find in the buffer?
81            (cond
82              ;; A single byte.
83              ((numberp from-buffer)
84               (setf (elt sequence start) from-buffer)
85               (incf start)
86               (pop buffer))
87              ;; A sequence.
88              ((listp from-buffer)
89               (let* ((has-newline (eql (fourth from-buffer) :line))
90                      (len (min (- end start) 
91                                (- (second from-buffer) (first from-buffer)))))
92                 (setf (subseq sequence start (+ start len))
93                       (subseq (third from-buffer) (+ (first from-buffer) len)))
94                 (incf start len)
95                 (incf (first from-buffer) len)
96                 ;; If the sequence is exhausted, drop it.
97                 (when (= (first from-buffer) (second from-buffer))
98                   (if (not has-newline)
99                       (pop buffer)
100                       ;; Is there space for the newline?
101                       (if (< start end)
102                           ;; Yes - line is entirely consumed.
103                           (progn
104                             (setf (elt sequence start) 10)
105                             (incf start)
106                             (pop buffer))
107                           ;; No - preserve the newline.
108                           (setf (car buffer) 10)))))))))
109
110    ;; If we need more data, get it from the base stream.
111    (if (< start end)
112        (read-sequence sequence base-stream :start start :end end)
113        ;; Otherwise, report that the sequence is full.
114        end)))
115
116(defmethod read-binary-line ((stream unreadable-stream) &optional (eof-error-p t) eof-value)
117  "If stream is in \"Haskell mode\", treat newlines at end of file accordingly."
118  (if (not (slot-value stream 'haskellish-lines))
119      (call-next-method)
120      ;; The delimiter between lines is a newline or end-of-file.
121      ;; Thus, if we have just returned the last newline-terminated
122      ;; line and stand before EOF, we can't just return EOF since
123      ;; there is an zero-length line between the last newline and the
124      ;; EOF.
125      (if (null (slot-value stream 'at-end-of-file))
126          ;; So we haven't read EOF yet.  That means that we can
127          ;; return at least one more line (though it may be
128          ;; zero-length).
129          (multiple-value-bind (line delim)
130              (read-until 10 stream nil :eof)
131            ;; If EOF follows after that line, note it.
132            (when (eql delim :eof)
133              (setf (slot-value stream 'at-end-of-file) t))
134            line)
135          ;; If we have already set the EOF flag, act accordingly.
136          (if eof-error-p
137              (error 'end-of-file :stream stream)
138              eof-value))))
139
140;; This method is meant as an optimization, but it actually makes
141;; things slower.  Need to investigate why...
142#+nil 
143(defmethod read-binary-line :around ((stream unreadable-stream) &optional (eof-error-p t) eof-value)
144  "If possible, return a recently unread line."
145  ;; If a line has been unread, we just return it.
146  (with-slots (buffer) stream
147    (let ((buffer-entry (car buffer)))
148      (if (and (listp buffer-entry) (eql (fourth buffer-entry) :line))
149          ;; Yes!
150          (let ((start (first buffer-entry))
151                (end (second buffer-entry))
152                (sequence (third buffer-entry)))
153            (pop buffer)
154            ;; Simple case: it's a vector, and we haven't begun nibbling at it.
155            (if (and (vectorp sequence) (= start 0))
156                sequence
157                ;; Otherwise, make a new vector.
158                (make-array (- end start) :element-type '(unsigned-byte 8)
159                            :initial-contents (subseq sequence start))))
160          ;; Oh well...
161          (call-next-method)))))
162
163(defmethod close ((stream unreadable-stream) &key abort)
164  "Close the underlying stream of STREAM."
165  (close (slot-value stream 'stream) :abort abort)
166  (call-next-method))
167
168(defmethod unread-byte ((stream unreadable-stream) byte)
169  "Store BYTE at the head of the unread buffer."
170  (setf (slot-value stream 'at-end-of-file) nil)
171  (push byte (slot-value stream 'buffer)))
172
173(defmethod unread-sequence ((stream unreadable-stream) sequence)
174  "Store SEQUENCE at the head of the unread buffer.
175It is assumed that SEQUENCE will not be modified."
176  (setf (slot-value stream 'at-end-of-file) nil)
177  (with-slots (buffer) stream
178    ;; Empty sequences must not be stored in the buffer.
179    (unless (zerop (length sequence))
180      (push (list 0 (length sequence) sequence) buffer))))
181
182(defmethod unread-line ((stream unreadable-stream) line)
183  "Store LINE with an appended newline at the head of the unread buffer.
184It is assumed that SEQUENCE will not be modified."
185  (setf (slot-value stream 'at-end-of-file) nil)
186  (with-slots (buffer) stream
187    ;; If the line is empty, just store a newline.
188    (if (zerop (length line))
189        (push 10 buffer)
190        (push (list 0 (length line) line :line) buffer))))
191
192(defmethod print-object ((object unreadable-stream) stream)
193  (print-unreadable-object (object stream :type t)
194    (format stream "~A ~A" (slot-value object 'buffer) (slot-value object 'stream))))
Note: See TracBrowser for help on using the repository browser.