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. |
---|
28 | That is, a line is a (possibly empty) list of characters delimited |
---|
29 | by either newlines or end-of-file. In particular, if the file ends |
---|
30 | with a newline, it has an extra empty last line in Haskell mode. |
---|
31 | |
---|
32 | This 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. |
---|
37 | Unlimited \"unreading\" is allowed through UNREAD-BYTE and |
---|
38 | UNREAD-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. |
---|
175 | It 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. |
---|
184 | It 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)))) |
---|