Coverage report: /home/ellis/comp/core/std/stream.lisp

KindCoveredAll%
expression7212 3.3
branch026 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; std/stream.lisp --- Standard Streams
2
 
3
 ;;
4
 
5
 ;;; Code:
6
 (in-package :std/stream)
7
 (declaim (optimize speed))
8
 
9
 (definline read-until-end (stream)
10
   "Read input from STREAM until EOF and return a string."
11
   (with-output-to-string (s)
12
     (loop for c = (read-char stream nil)
13
           until (not c)
14
           do (write-char c s))))
15
 
16
 (definline read-lisp-until-end (stream)
17
   "Read input from STREAM until EOF and return a form."
18
   (with-gensyms (eof)
19
     (loop for c = (read stream nil eof)
20
           until (eql c eof)
21
           collect c)))
22
 
23
 (definline copy-stream (input output &key (element-type (stream-element-type input))
24
                     (buffer-size 4096)
25
                     (buffer (make-array buffer-size :element-type element-type))
26
                     (start 0) end
27
                     finish-output)
28
   "Reads data from INPUT and writes it to OUTPUT. Both INPUT and OUTPUT must
29
 be streams, they will be passed to READ-SEQUENCE and WRITE-SEQUENCE and must have
30
 compatible element-types."
31
   (check-type start non-negative-integer)
32
   (check-type end (or null non-negative-integer))
33
   (check-type buffer-size positive-integer)
34
   (when (and end
35
              (< end start))
36
     (error "END is smaller than START in ~S" 'copy-stream))
37
   (let ((output-position 0)
38
         (input-position 0))
39
     (unless (zerop start)
40
       ;; FIXME add platform specific optimization to skip seekable streams
41
       (loop while (< input-position start)
42
             do (let ((n (read-sequence buffer input
43
                                        :end (min (length buffer)
44
                                                  (- start input-position)))))
45
                  (when (zerop n)
46
                    (error "~@<Could not read enough bytes from the input to fulfill ~
47
                            the :START ~S requirement in ~S.~:@>" 'copy-stream start))
48
                  (incf input-position n))))
49
     (assert (= input-position start))
50
     (loop while (or (null end) (< input-position end))
51
           do (let ((n (read-sequence buffer input
52
                                      :end (when end
53
                                             (min (length buffer)
54
                                                  (- end input-position))))))
55
                (when (zerop n)
56
                  (if end
57
                      (error "~@<Could not read enough bytes from the input to fulfill ~
58
                           the :END ~S requirement in ~S.~:@>" 'copy-stream end)
59
                      (return)))
60
                (incf input-position n)
61
                (write-sequence buffer output :end n)
62
                (incf output-position n)))
63
     (when finish-output
64
       (finish-output output))
65
     output-position))
66
 
67
 ;; from SBCL manual
68
 ;;; Wrapped Streams
69
 (defclass wrapped-stream (fundamental-stream)
70
   ((stream :initarg :stream :reader stream-of))
71
   (:documentation "A stream which wraps another stream accessible via STREAM-OF."))
72
 
73
 (defmethod open-stream-p ((stream wrapped-stream))
74
   (open-stream-p (stream-of stream)))
75
 
76
 (defmethod stream-element-type ((stream wrapped-stream))
77
   (stream-element-type (stream-of stream)))
78
 
79
 (defmethod close ((stream wrapped-stream) &key abort)
80
   (close (stream-of stream) :abort abort))
81
 
82
 (defun wrapped-stream-p (obj) (typep obj 'wrapped-stream))
83
 
84
 (defclass wrapped-character-input-stream (wrapped-stream fundamental-character-input-stream)
85
   ()
86
   (:documentation "A wrapped CHARACTER-INPUT-STREAM."))
87
 
88
 (defmethod stream-read-char ((stream wrapped-character-input-stream))
89
   (read-char (stream-of stream) nil :eof))
90
 
91
 (defmethod stream-unread-char ((stream wrapped-character-input-stream)
92
                                char)
93
   (unread-char char (stream-of stream)))
94
 
95
 #| example:
96
 (with-input-from-string (input "1 2
97
  3 :foo  ")
98
   (let ((counted-stream (make-instance 'counting-character-input-stream
99
                          :stream input)))
100
     (loop for thing = (read counted-stream) while thing
101
        unless (numberp thing) do
102
          (error "Non-number ~S (line ~D, column ~D)" thing
103
                 (line-count-of counted-stream)
104
                 (- (col-count-of counted-stream)
105
                    (length (format nil "~S" thing))))
106
        end
107
        do (print thing))))
108
 1
109
 2
110
 3
111
 Non-number :FOO (line 2, column 5)
112
   [Condition of type SIMPLE-ERROR]
113
 |#
114
 (defclass counting-character-input-stream (wrapped-character-input-stream)
115
   ((char-count :initform 1 :accessor char-count-of)
116
    (line-count :initform 1 :accessor line-count-of)
117
    (col-count :initform 1 :accessor col-count-of)
118
    (prev-col-count :initform 1 :accessor prev-col-count-of))
119
   (:documentation "A CHARACTER-INPUT-STREAM with automatic counters:
120
 
121
 - CHAR-COUNT via CHAR-COUNT-OF
122
 - LINE-COUNT via LINE-COUNT-OF
123
 - COL-COUNT via COL-COUNT-OF
124
 - PREV-COL-COUNT via PREV-COL-COUNT-OF"))
125
 
126
 (defmethod stream-read-char ((stream counting-character-input-stream))
127
   (with-accessors ((inner-stream stream-of) (chars char-count-of)
128
                    (lines line-count-of) (cols col-count-of)
129
                    (prev prev-col-count-of)) stream
130
       (let ((char (call-next-method)))
131
         (cond ((eql char :eof)
132
                :eof)
133
               ((char= char #\Newline)
134
                (incf lines)
135
                (incf chars)
136
                (setf prev cols)
137
                (setf cols 1)
138
                char)
139
               (t
140
                (incf chars)
141
                (incf cols)
142
                char)))))
143
 
144
 (defmethod stream-unread-char ((stream counting-character-input-stream)
145
                                char)
146
   (with-accessors ((inner-stream stream-of) (chars char-count-of)
147
                    (lines line-count-of) (cols col-count-of)
148
                    (prev prev-col-count-of)) stream
149
       (cond ((char= char #\Newline)
150
              (decf lines)
151
              (decf chars)
152
              (setf cols prev))
153
             (t
154
              (decf chars)
155
              (decf cols)
156
              char))
157
       (call-next-method)))
158
 
159
 (defclass wrapped-character-output-stream (wrapped-stream fundamental-character-output-stream)
160
   ((col-index :initform 0 :accessor col-index-of))
161
   (:documentation "A wrapped CHARACTER-OUTPUT-STREAM with the current column index accessible via
162
 COL-INDEX-OF."))
163
 
164
 (defmethod stream-line-column ((stream wrapped-character-output-stream))
165
   (col-index-of stream))
166
 
167
 (defmethod stream-write-char ((stream wrapped-character-output-stream)
168
                               char)
169
   (with-accessors ((inner-stream stream-of) (cols col-index-of)) stream
170
     (write-char char inner-stream)
171
     (if (char= char #\Newline)
172
         (setf cols 0)
173
         (incf cols))))
174
 
175
 #| example:
176
 (flet ((format-timestamp (stream)
177
          (apply #'format stream "[~2@*~2,' D:~1@*~2,'0D:~0@*~2,'0D] "
178
                 (multiple-value-list (get-decoded-time)))))
179
   (let ((output (make-instance 'prefixed-character-output-stream
180
                                :stream *standard-output*
181
                                :prefix #'format-timestamp)))
182
     (loop for string in '("abc" "def" "ghi") do
183
          (write-line string output)
184
          (sleep 1))))
185
 [00:30:05] abc
186
 [00:30:06] def
187
 [00:30:07] ghi
188
 NIL
189
 |#
190
 (defclass prefixed-character-output-stream
191
     (wrapped-character-output-stream)
192
   ((prefix :initarg :prefix :reader prefix-of))
193
   (:documentation "A CHARACTER-OUTPUT-STREAM which automatically writes each line of output with
194
 a designated prefix accessible via PREFIX-OF."))
195
 
196
 (defgeneric write-prefix (prefix stream)
197
   (:method ((prefix string) stream) (write-string prefix stream))
198
   (:method ((prefix function) stream) (funcall prefix stream))
199
   (:documentation "Write a PREFIX to STREAM."))
200
 
201
 (defmethod stream-write-char ((stream prefixed-character-output-stream)
202
                               char)
203
   (with-accessors ((inner-stream stream-of) (cols col-index-of)
204
                    (prefix prefix-of)) stream
205
     (when (zerop cols)
206
       (write-prefix prefix inner-stream))
207
     (call-next-method)))
208
 
209
 ;;; Input Macros
210
 (defmacro with-input-from-file ((stream-name file-name &rest args
211
                                              &key (direction nil direction-p)
212
                                              &allow-other-keys)
213
                                 &body body)
214
   "Evaluate BODY with STREAM-NAME to an input stream on the file
215
 FILE-NAME."
216
   (declare (ignore direction))
217
   (when direction-p
218
     (error "Can't specify :DIRECTION for WITH-INPUT-FROM-FILE."))
219
   `(with-open-file (,stream-name ,file-name :direction :input ,@args)
220
      ,@body))
221
 
222
 (defmacro with-output-to-file ((stream-name file-name &rest args
223
                                             &key (direction nil direction-p)
224
                                             &allow-other-keys)
225
                                &body body)
226
   "Evaluate BODY with STREAM-NAME to an output stream on the file
227
 FILE-NAME."
228
   (declare (ignore direction))
229
   (when direction-p
230
     (error "Can't specify :DIRECTION for WITH-OUTPUT-TO-FILE."))
231
   `(with-open-file (,stream-name ,file-name :direction :output ,@args)
232
      ,@body))