Coverage report: /home/ellis/.stash/quicklisp/dists/ultralisp/software/edicl-flexi-streams-20240429143708/input.lisp

KindCoveredAll%
expression0242 0.0
branch026 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: FLEXI-STREAMS; Base: 10 -*-
2
 ;;; $Header: /usr/local/cvsrep/flexi-streams/input.lisp,v 1.78 2008/05/25 19:25:44 edi Exp $
3
 
4
 ;;; Copyright (c) 2005-2008, Dr. Edmund Weitz.  All rights reserved.
5
 
6
 ;;; Redistribution and use in source and binary forms, with or without
7
 ;;; modification, are permitted provided that the following conditions
8
 ;;; are met:
9
 
10
 ;;;   * Redistributions of source code must retain the above copyright
11
 ;;;     notice, this list of conditions and the following disclaimer.
12
 
13
 ;;;   * Redistributions in binary form must reproduce the above
14
 ;;;     copyright notice, this list of conditions and the following
15
 ;;;     disclaimer in the documentation and/or other materials
16
 ;;;     provided with the distribution.
17
 
18
 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
19
 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
20
 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
21
 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
22
 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
23
 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
24
 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
25
 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
26
 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
27
 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
28
 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
29
 
30
 (in-package :flexi-streams)
31
 
32
 #-:lispworks
33
 (defmethod read-byte* ((flexi-input-stream flexi-input-stream))
34
   "Reads one byte \(octet) from the underlying stream of
35
 FLEXI-OUTPUT-STREAM \(or from the internal stack if it's not
36
 empty)."
37
   (declare #.*standard-optimize-settings*)
38
   ;; we're using S instead of STREAM here because of an
39
   ;; issue with SBCL:
40
   ;; <http://article.gmane.org/gmane.lisp.steel-bank.general/1386>
41
   (with-accessors ((position flexi-stream-position)
42
                    (bound flexi-stream-bound)
43
                    (octet-stack flexi-stream-octet-stack)
44
                    (s flexi-stream-stream))
45
       flexi-input-stream
46
     (declare (integer position)
47
              (type (or null integer) bound))
48
     (when (and bound
49
                (>= position bound))
50
       (return-from read-byte* nil))
51
     (incf position)
52
     (or (pop octet-stack)
53
         (read-byte s nil nil)
54
         (progn (decf position) nil))))
55
 
56
 #+:lispworks
57
 (defmethod read-byte* ((flexi-input-stream flexi-input-stream))
58
   "Reads one byte \(octet) from the underlying \(binary) stream of
59
 FLEXI-OUTPUT-STREAM \(or from the internal stack if it's not empty)."
60
   (declare #.*standard-optimize-settings*)
61
   (with-accessors ((position flexi-stream-position)
62
                    (bound flexi-stream-bound)
63
                    (octet-stack flexi-stream-octet-stack)
64
                    (stream flexi-stream-stream))
65
       flexi-input-stream
66
     (declare (integer position)
67
              (type (or null integer) bound))
68
     (when (and bound
69
                (>= position bound))
70
       (return-from read-byte* nil))
71
     (incf position)
72
     (or (pop octet-stack)
73
         (read-byte stream nil nil)
74
         (progn (decf position) nil))))
75
 
76
 #+:lispworks
77
 (defmethod read-byte* ((flexi-input-stream flexi-char-input-stream))
78
   "Reads one byte \(octet) from the underlying stream of
79
 FLEXI-OUTPUT-STREAM \(or from the internal stack if it's not empty).
80
 Only used for LispWorks bivalent streams which aren't binary."
81
   (declare #.*standard-optimize-settings*)
82
   (with-accessors ((position flexi-stream-position)
83
                    (bound flexi-stream-bound)
84
                    (octet-stack flexi-stream-octet-stack)
85
                    (stream flexi-stream-stream))
86
       flexi-input-stream
87
     (declare (integer position)
88
              (type (or null integer) bound))
89
     (when (and bound
90
                (>= position bound))
91
       (return-from read-byte* nil))
92
     (incf position)
93
     (or (pop octet-stack)
94
         ;; we use READ-SEQUENCE because READ-BYTE doesn't work with all
95
         ;; bivalent streams in LispWorks
96
         (let* ((buffer (make-array 1 :element-type 'octet))
97
                (new-position (read-sequence buffer stream)))
98
           (cond ((zerop new-position)
99
                  (decf position) nil)
100
                 (t (aref buffer 0)))))))
101
 
102
 (defmethod stream-clear-input ((flexi-input-stream flexi-input-stream))
103
   "Calls the corresponding method for the underlying input stream
104
 and also clears the value of the OCTET-STACK slot."
105
   (declare #.*standard-optimize-settings*)
106
   ;; note that we don't reset the POSITION slot
107
   (with-accessors ((octet-stack flexi-stream-octet-stack)
108
                    (stream flexi-stream-stream))
109
       flexi-input-stream
110
     (setq octet-stack nil)
111
     (clear-input stream)))
112
 
113
 (defmethod stream-listen ((flexi-input-stream flexi-input-stream))
114
   "Calls the corresponding method for the underlying input stream
115
 but first checks if \(old) input is available in the OCTET-STACK
116
 slot."
117
   (declare #.*standard-optimize-settings*)
118
   (with-accessors ((position flexi-stream-position)
119
                    (bound flexi-stream-bound)
120
                    (octet-stack flexi-stream-octet-stack)
121
                    (stream flexi-stream-stream))
122
       flexi-input-stream
123
     (declare (integer position)
124
              (type (or null integer) bound))
125
     (when (and bound
126
                (>= position bound))
127
       (return-from stream-listen nil))
128
     (or octet-stack (listen stream))))
129
 
130
 (defmethod stream-read-byte ((stream flexi-input-stream))
131
   "Reads one byte \(octet) from the underlying stream."
132
   (declare #.*standard-optimize-settings*)
133
   ;; set LAST-CHAR-CODE slot to NIL because we can't UNREAD-CHAR after
134
   ;; this operation
135
   (with-accessors ((last-char-code flexi-stream-last-char-code)
136
                    (last-octet flexi-stream-last-octet))
137
       stream
138
     (setq last-char-code nil)
139
     (let ((octet (read-byte* stream)))
140
       (setq last-octet octet)
141
       (or octet :eof))))
142
 
143
 (defun unread-char% (char flexi-input-stream)
144
   "Used internally to put a character CHAR which was already read back
145
 on the stream.  Uses the OCTET-STACK slot and decrements the POSITION
146
 slot accordingly."
147
   (declare #.*standard-optimize-settings*)
148
   (with-accessors ((position flexi-stream-position)
149
                    (octet-stack flexi-stream-octet-stack)
150
                    (external-format flexi-stream-external-format))
151
       flexi-input-stream
152
     (let ((counter 0) octets-reversed)
153
       (declare (fixnum counter))
154
       (flet ((writer (octet)
155
                (incf counter)
156
                (push octet octets-reversed)))
157
         (declare (dynamic-extent (function writer)))
158
         (char-to-octets external-format char #'writer)
159
         (decf position counter)
160
         (setq octet-stack (nreconc octets-reversed octet-stack))))))
161
 
162
 (defmethod stream-read-char ((stream flexi-input-stream))
163
   (declare #.*standard-optimize-settings*)
164
   ;; note that we do nothing for the :LF EOL style because we assume
165
   ;; that #\Newline is the same as #\Linefeed in all Lisps which will
166
   ;; use this library
167
   (with-accessors ((external-format flexi-stream-external-format)
168
                    (last-octet flexi-stream-last-octet)
169
                    (last-char-code flexi-stream-last-char-code))
170
       stream
171
     ;; set LAST-OCTET slot to NIL because we can't UNREAD-BYTE after
172
     ;; this operation
173
     (setq last-octet nil)
174
     (flet ((reader ()
175
              (read-byte* stream))
176
            (unreader (char)
177
              (unread-char% char stream)))
178
       (declare (dynamic-extent (function reader) (function unreader)))
179
       (let* ((*current-unreader* #'unreader)
180
              (char-code (or (octets-to-char-code external-format #'reader)
181
                             (return-from stream-read-char :eof))))
182
         ;; remember this character and its char code for UNREAD-CHAR
183
         (setq last-char-code char-code)
184
         (or (code-char char-code) char-code)))))
185
 
186
 (defmethod stream-read-char-no-hang ((stream flexi-input-stream))
187
   "Reads one character if the underlying stream has at least one
188
 octet available."
189
   (declare #.*standard-optimize-settings*)
190
   ;; note that this may block for non-8-bit encodings - I think
191
   ;; there's no easy way to handle this correctly
192
   (and (stream-listen stream)
193
        (stream-read-char stream)))
194
 
195
 (defmethod stream-read-sequence ((flexi-input-stream flexi-input-stream) sequence start end &key)
196
   "An optimized version which uses a buffer underneath.  The function
197
 can deliver characters as well as octets and it decides what to do
198
 based on the element type of the sequence \(which takes precedence)
199
 and the element type of the stream.  What you'll really get might also
200
 depend on your Lisp.  Some of the implementations are more picky than
201
 others - see for example FLEXI-STREAMS-TEST::SEQUENCE-TEST."
202
   (declare #.*standard-optimize-settings*)
203
   (declare (fixnum start end))
204
   (with-accessors ((octet-stack flexi-stream-octet-stack)
205
                    (external-format flexi-stream-external-format)
206
                    (last-octet flexi-stream-last-octet)
207
                    (last-char-code flexi-stream-last-char-code)
208
                    (element-type flexi-stream-element-type)
209
                    (stream flexi-stream-stream)
210
                    (position flexi-stream-position)
211
                    (bound flexi-stream-bound))
212
       flexi-input-stream
213
     (when (>= start end)
214
       (return-from stream-read-sequence start))
215
     (when (or (typep sequence
216
                      '(and vector
217
                        (not string)
218
                        (not (vector t))))
219
               (and (not (stringp sequence))
220
                    (type-equal element-type 'octet)))
221
       ;; if binary data is requested, just read from the underlying
222
       ;; stream directly and skip the rest (but flush octet stack
223
       ;; first)
224
       (let ((index start)
225
             (end (if bound
226
                      (min end (+ start (- bound position)))
227
                      end)))
228
         (declare (fixnum index))
229
         (when octet-stack
230
           (replace sequence octet-stack :start1 start :end1 end)
231
           (let ((octets-flushed (min (length octet-stack) (- end start))))
232
             (incf index octets-flushed)
233
             (setq octet-stack (nthcdr octets-flushed octet-stack))))
234
         (setq index (read-sequence sequence stream :start index :end end))
235
         (when (> index start)
236
           (setq last-char-code nil
237
                 last-octet (elt sequence (1- index))))
238
         (incf position (- index start))
239
         (return-from stream-read-sequence index)))
240
     ;; otherwise hand over to the external format to do the work
241
     (read-sequence* external-format flexi-input-stream sequence start end)))
242
 
243
 (defmethod stream-unread-char ((stream flexi-input-stream) char)
244
   "Implements UNREAD-CHAR for streams of type FLEXI-INPUT-STREAM.
245
 Makes sure CHAR will only be unread if it was the last character
246
 read and if it was read with the same encoding that's currently
247
 being used by the stream."
248
   (declare #.*standard-optimize-settings*)
249
   (with-accessors ((last-char-code flexi-stream-last-char-code))
250
       stream
251
     (unless last-char-code
252
       (error 'flexi-stream-error
253
              :stream stream
254
              :format-control "No character to unread from this stream \(or external format has changed or last reading operation was binary)."))
255
     (unless (= (char-code char) last-char-code)
256
       (error 'flexi-stream-error
257
              :stream stream
258
              :format-control "Last character read (~S) was different from ~S."
259
              :format-arguments (list (code-char last-char-code) char)))
260
     (unread-char% char stream)
261
     (setq last-char-code nil)
262
     nil))
263
 
264
 (defmethod unread-byte (byte (flexi-input-stream flexi-input-stream))
265
   "Similar to UNREAD-CHAR in that it `unreads' the last octet from
266
 STREAM.  Note that you can only call UNREAD-BYTE after a corresponding
267
 READ-BYTE."
268
   (declare #.*standard-optimize-settings*)
269
   (with-accessors ((last-octet flexi-stream-last-octet)
270
                    (octet-stack flexi-stream-octet-stack)
271
                    (position flexi-stream-position))
272
       flexi-input-stream
273
     (unless last-octet
274
       (error 'flexi-stream-error
275
              :stream flexi-input-stream
276
              :format-control "No byte to unread from this stream \(or last reading operation read a character)."))
277
     (unless (= byte last-octet)
278
       (error 'flexi-stream-error
279
              :stream flexi-input-stream
280
              :format-control "Last byte read was different from #x~X."
281
              :format-arguments (list byte)))
282
     (setq last-octet nil)
283
     (decf (the integer position))
284
     (push byte octet-stack)
285
     nil))
286
 
287
 (defmethod peek-byte ((flexi-input-stream flexi-input-stream)
288
                       &optional peek-type (eof-error-p t) eof-value)
289
   "Returns an octet from FLEXI-INPUT-STREAM without actually removing it."
290
   (declare #.*standard-optimize-settings*)
291
   (loop for octet = (read-byte flexi-input-stream eof-error-p :eof)
292
         until (cond ((eq octet :eof)
293
                      (return eof-value))
294
                     ((null peek-type))
295
                     ((eq peek-type t)
296
                      (plusp octet))
297
                     ((= octet peek-type)))
298
         finally (unread-byte octet flexi-input-stream)
299
                 (return octet)))