Commit f69b6008 authored by Eric Timmons's avatar Eric Timmons
Browse files

Fix bug using FILE-POSITION to jump across BLOCKED-STREAM blocks

parent cba01ce0
......@@ -2,6 +2,8 @@
+ Fix bug where strings read from headers were not bounded to the length of the
field.
+ Fix bug when using FILE-POSITION to jump across block boundaries on
BLOCKED-STREAMs.
## v0.1.1 - September 23, 2021
......
......@@ -43,7 +43,7 @@ START-FILE-POSITION.")
:accessor buffer-valid-p
:initform nil
:documentation
"T iff the BUFFER is valid.")
"T iff the BUFFER has been read at the current OFFSET.")
(buffer
:accessor buffer
:documentation
......@@ -93,11 +93,6 @@ of the wrapped stream when instantiated."))
;; Record the START-FILE-POSITION
(start-file-position blocked-stream) (ignore-errors (file-position stream)))))
(defmethod initialize-instance :after ((blocked-stream blocked-input-stream)
&key
stream)
(setf (stream-offset blocked-stream) (- (block-size blocked-stream))))
(defgeneric discard-buffer (stream)
(:documentation
"Must be called to clean up the current buffer. Resets internal state and
......@@ -148,19 +143,24 @@ the buffer to be written."
(defmethod ensure-buffer-valid ((stream blocked-stream))
(cond
;; We haven't read from the current offset, so just fill it.
((not (buffer-valid-p stream))
(incf (stream-offset stream) (block-size stream))
(fill-buffer stream))
;; We're at the end of the current buffer, discard it, reset the pointer to
;; the start, increase the offset, and fill it.
((= (index stream) (block-size stream))
(discard-buffer stream)
(setf (index stream) 0)
(incf (stream-offset stream) (block-size stream))
(fill-buffer stream))
;; We've moved past the edge of the buffer. Discard it,
((> (index stream) (block-size stream))
(discard-buffer stream)
(loop :while (> (index stream) (block-size stream))
:do
(decf (index stream) (block-size stream))
(incf (stream-offset stream) (block-size stream))
(ensure-buffer-valid stream))))
(incf (stream-offset stream) (block-size stream)))
(fill-buffer stream))))
(defmethod trivial-gray-streams:stream-read-byte ((stream blocked-input-stream))
(ensure-buffer-valid stream)
......@@ -229,13 +229,6 @@ the buffer to be written."
(let* ((start-of-chunk-position (* (block-size stream)
(floor (/ newval (block-size stream)))))
(new-index (- newval start-of-chunk-position)))
(flet ((read-forward ()
(loop
:while (/= (stream-offset stream) start-of-chunk-position)
:do
(discard-buffer stream)
(setf (index stream) (block-size stream))
(ensure-buffer-valid stream))))
(cond
((and (= start-of-chunk-position (stream-offset stream))
(or (null (eof-index stream))
......@@ -255,8 +248,9 @@ the buffer to be written."
;; determine the starting FILE-POSITION of the wrapped stream. However,
;; we want to seek forward, so we can just read blocks until we get
;; there.
(read-forward)
(setf (index stream) new-index)
(discard-buffer)
(setf (index stream) (+ start-of-chunk-position new-index))
(ensure-buffer-valid)
t)
((null (start-file-position stream))
;; We weren't able to figure out the start position of the wrapped
......@@ -271,8 +265,9 @@ the buffer to be written."
(stream-offset stream) start-of-chunk-position)
t)
(when (> start-of-chunk-position (stream-offset stream))
(read-forward)
t)))))))
(setf (index stream) (+ start-of-chunk-position new-index))
(ensure-buffer-valid)
t))))))
(defmethod close ((stream blocked-stream) &key abort)
(unless abort
......
......@@ -78,3 +78,66 @@
(para:is eql :eof (read-byte s nil :eof))
(file-position s 0)
(para:is = (char-code #\a) (read-byte s))))))
(para:define-test jumping-across-blocks
(uiop:with-temporary-file (:stream raw-stream :pathname pn
:element-type '(unsigned-byte 8))
(write-sequence (make-array 1024 :element-type '(unsigned-byte 8)
:initial-element 0)
raw-stream)
(write-sequence (make-array 1024 :element-type '(unsigned-byte 8)
:initial-element 1)
raw-stream)
:close-stream
(with-open-file (raw-stream pn
:element-type '(unsigned-byte 8))
(with-open-stream (s (make-instance 'tar-file::blocked-input-stream
:stream raw-stream
:block-size 1024))
(let ((seq (make-array 512 :element-type '(unsigned-byte 8)
:initial-element 0)))
(read-sequence seq s)
(para:true (every #'zerop seq))
(read-sequence seq s)
(para:true (every #'zerop seq))
(read-sequence seq s)
(para:true (every (lambda (x) (= x 1)) seq))
(file-position s 512)
(read-sequence seq s)
(para:true (every #'zerop seq))
(read-sequence seq s)
(para:true (every (lambda (x) (= x 1)) seq)))))))
(para:define-test bounded-stream-jumping-across-blocks
(uiop:with-temporary-file (:stream raw-stream :pathname pn
:element-type '(unsigned-byte 8))
(write-sequence (make-array 1024 :element-type '(unsigned-byte 8)
:initial-element 0)
raw-stream)
(write-sequence (make-array 1024 :element-type '(unsigned-byte 8)
:initial-element 1)
raw-stream)
:close-stream
(with-open-file (raw-stream pn
:element-type '(unsigned-byte 8))
(with-open-stream (s (make-instance 'tar-file::blocked-input-stream
:stream raw-stream
:block-size 1024))
(let ((seq-1 (make-array 512 :element-type '(unsigned-byte 8)
:initial-element 0))
(seq-2 (make-array 1024 :element-type '(unsigned-byte 8)
:initial-element 0)))
(read-sequence seq-1 s)
(para:true (every #'zerop seq-1))
(with-open-stream (bounded-stream (tar-file::make-bounded-stream s 1024))
(read-sequence seq-2 bounded-stream)
(para:true (every #'zerop (subseq seq-2 0 512)))
(para:true (every (lambda (x) (= x 1)) (subseq seq-2 512))))
(with-open-stream (bounded-stream (tar-file::make-bounded-stream s 1024 512))
(read-sequence seq-2 bounded-stream)
(para:true (every #'zerop (subseq seq-2 0 512)))
(para:true (every (lambda (x) (= x 1)) (subseq seq-2 512))))
(read-sequence seq-1 s)
(para:true (every (lambda (x) (= x 1)) seq-1)))))))
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment