2 ;;; Copyright (c) 2021 Eric Timmons, All Rights Reserved
4 ;;; Redistribution and use in source and binary forms, with or without
5 ;;; modification, are permitted provided that the following conditions
8 ;;; * Redistributions of source code must retain the above copyright
9 ;;; notice, this list of conditions and the following disclaimer.
11 ;;; * Redistributions in binary form must reproduce the above
12 ;;; copyright notice, this list of conditions and the following
13 ;;; disclaimer in the documentation and/or other materials
14 ;;; provided with the distribution.
16 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
17 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
18 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
19 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
20 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
21 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
22 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
23 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
24 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
25 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
26 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 (define-condition stream-closed-error
(stream-error)
33 (:documentation
"Signaled when attempting to write to a closed COMPRESSING-STREAM.")
34 (:report
(lambda (condition stream
)
35 (format stream
"Stream ~S is closed" (stream-error-stream condition
)))))
37 (defclass compressing-stream
(trivial-gray-streams:fundamental-binary-output-stream
)
43 :accessor compressor
))
45 "A gray stream that transparently compresses its input and writes the
46 compressed data to another stream."))
48 (defun make-compressing-stream (compressor-type stream
)
49 "Return a COMPRESSING-STREAM that transparently compresses its input and
50 writes it to STREAM. COMPRESSOR-TYPE is a symbol naming the compressor class to
53 Closing the returned COMPRESSING-STREAM merely finalizes the compression and
54 does not close STREAM."
57 :compressor
(make-instance
59 :callback
(make-stream-output-callback stream
))))
62 (defmethod trivial-gray-streams:stream-write-byte
((stream compressing-stream
) byte
)
63 (unless (openp stream
)
64 (error 'stream-closed-error
:stream stream
))
65 (compress-octet byte
(compressor stream
))
68 (defmethod trivial-gray-streams:stream-write-sequence
((stream compressing-stream
) sequence start end
&key
)
69 (unless (openp stream
)
70 (error 'stream-closed-error
:stream stream
))
71 (let ((vector (if (typep sequence
'vector
)
73 (coerce sequence
'vector
))))
74 (compress-octet-vector vector
(compressor stream
) :start start
:end end
))
77 (defmethod trivial-gray-streams:stream-file-position
((stream compressing-stream
))
78 "Does not keep track of position in the stream."
81 (defmethod (setf trivial-gray-streams
:stream-file-position
) (newval (stream compressing-stream
))
82 "Unable to seek within the stream."
83 (declare (ignore newval
))
86 (defmethod stream-element-type ((stream compressing-stream
))
89 (defmethod close ((stream compressing-stream
) &key abort
)
90 (declare (ignore abort
))
92 (finish-compression (compressor stream
))
93 (setf (openp stream
) nil
)