pax_global_header00006660000000000000000000000064121721251410014506gustar00rootroot0000000000000052 comment=dc8cda846c36b0b0b34601fbda207bc2dafa014d salza2-2.0.9/000077500000000000000000000000001217212514100127125ustar00rootroot00000000000000salza2-2.0.9/LICENSE.txt000066400000000000000000000025221217212514100145360ustar00rootroot00000000000000;;; ;;; Copyright (c) 2007 Zachary Beane, All Rights Reserved ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; salza2-2.0.9/README.txt000066400000000000000000000003361217212514100144120ustar00rootroot00000000000000salza2 can compress data in the ZLIB and DEFLATE data formats. It is available under a BSD-like license. For documentation, see the doc/ directory. For any questions or comments, please email Zach Beane . salza2-2.0.9/adler32.lisp000066400000000000000000000064431217212514100150460ustar00rootroot00000000000000;;; ;;; Copyright (c) 2007 Zachary Beane, All Rights Reserved ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; (in-package #:salza2) (defconstant +adler32-base+ 65521) (defun adler32-update (adler-high adler-low buf start count) (declare (type array-index start count) (type (unsigned-byte 16) adler-high adler-low) (type octet-vector buf) (optimize speed)) (cond ((zerop count) (values adler-high adler-low)) (t (let ((length count) (i 0) (k 0) (s1 adler-low) (s2 adler-high)) (declare (type (integer 0 16) k) (type array-index i) (type (unsigned-byte 16) length) (type (unsigned-byte 32) s1 s2)) (tagbody loop (setf k (min length 16)) (decf length k) sum (setf s1 (+ (aref buf (logand #xFFFF (+ start i))) s1)) (setf s2 (+ s1 s2)) (decf k) (incf i) (unless (zerop k) (go sum)) (setf s1 (mod s1 +adler32-base+)) (setf s2 (mod s2 +adler32-base+)) (unless (zerop length) (go loop))) (values s2 s1))))) ;;; Class interface (defclass adler32-checksum (checksum) ((high :initarg :high :accessor high) (low :initarg :low :accessor low)) (:default-initargs :high 0 :low 1)) (defmethod result ((checksum adler32-checksum)) (+ (ash (high checksum) 16) (low checksum))) (defmethod result-octets ((checksum adler32-checksum)) (ub32-octets (result checksum))) (defmethod update ((checksum adler32-checksum) buffer start count) (setf (values (high checksum) (low checksum)) (adler32-update (high checksum) (low checksum) buffer start count))) (defmethod reset ((checksum adler32-checksum)) (setf (high checksum) 0 (low checksum) 1)) salza2-2.0.9/bitstream.lisp000066400000000000000000000135761217212514100156110ustar00rootroot00000000000000;;; ;;; Copyright (c) 2007 Zachary Beane, All Rights Reserved ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; (in-package #:salza2) (defun bitstream-callback-missing (&rest args) (declare (ignore args)) (error "No callback set in bitstream")) (defun merge-bits (code size buffer bits callback) (declare (type (unsigned-byte 32) code) (type (integer 0 32) size) (type bitstream-buffer-bit-count bits) (type bitstream-buffer buffer) (type function callback) (optimize speed)) ;; BITS represents how many bits have been added to BUFFER so far, ;; so the FLOOR of it by 8 will give both the buffer byte index and ;; the bit index within that byte to where new bits should be ;; merged (let ((buffer-index (ash bits -3)) (bit (logand #b111 bits))) ;; The first byte to which new bits are merged might have some ;; bits in it already, so pull it out for merging back in the ;; loop. This only has to be done for the first byte, since ;; subsequent bytes in the buffer will consist solely of bits from ;; CODE. ;; ;; The check (PLUSP BIT) is done to make sure that no garbage bits ;; from a previous write are re-used; if (PLUSP BIT) is zero, all ;; bits in the first output byte come from CODE. (let ((merge-byte (if (plusp bit) (aref buffer buffer-index) 0)) (end #.+bitstream-buffer-size+) (result (+ bits size))) ;; (ceiling (+ bit size) 8) is the total number of bytes touched ;; in the buffer (dotimes (i (ceiling (+ bit size) 8)) (let ((shift (+ bit (* i -8))) (j (+ buffer-index i))) ;; Buffer filled up in the middle of CODE (when (= j end) (funcall callback buffer j)) ;; Merge part of CODE into the buffer (setf (aref buffer (logand #.+bitstream-buffer-mask+ j)) (logior (logand #xFF (ash code shift)) merge-byte)) (setf merge-byte 0))) ;; Writing is done, and the buffer is full, so call the callback (when (= result #.+bitstream-buffer-bits+) (funcall callback buffer #.+bitstream-buffer-size+)) ;; Return only the low bits of the sum (logand #.+bitstream-buffer-bitmask+ result)))) (defun merge-octet (octet buffer bits callback) (declare (type octet octet) (type bitstream-buffer buffer) (type bitstream-buffer-bit-count bits) (type function callback) (optimize speed)) (let ((offset (ceiling bits 8))) ;; End of the buffer beforehand (when (= offset #.+bitstream-buffer-size+) (funcall callback buffer #.+bitstream-buffer-size+) (setf offset 0 bits 0)) (setf (aref buffer offset) octet bits (+ bits 8)) (when (= (1+ offset) #.+bitstream-buffer-size+) (funcall callback buffer #.+bitstream-buffer-size+) (setf bits 0)) bits)) ;;; Protocol (defclass bitstream () ((buffer :initarg :buffer :accessor buffer :documentation "Holds accumulated bits packed into octets.") (bits :initarg :bits :accessor bits :documentation "The number of bits written to the buffer so far.") (callback :initarg :callback :accessor callback :documentation "A function of two arguments, BUFFER and END, that should write out all the data in BUFFER up to END.")) (:default-initargs :buffer (make-array +bitstream-buffer-size+ :element-type 'octet) :bits 0 :callback #'bitstream-callback-missing)) (defgeneric write-bits (code size bitstream)) (defgeneric write-octet (octet bitstream)) (defgeneric write-octet-vector (vector bitstream &key start end)) (defgeneric flush (bitstream)) (defmethod write-bits (code size (bitstream bitstream)) (setf (bits bitstream) (merge-bits code size (buffer bitstream) (bits bitstream) (callback bitstream)))) (defmethod write-octet (octet (bitstream bitstream)) (setf (bits bitstream) (merge-octet octet (buffer bitstream) (bits bitstream) (callback bitstream)))) (defmethod write-octet-vector (vector (bitstream bitstream) &key (start 0) end) ;;; Not efficient in the slightest, but not actually used internally. (let ((end (or end (length vector)))) (loop for i from start below end do (write-octet (aref vector i) bitstream)))) (defmethod flush ((bitstream bitstream)) (let ((end (ceiling (bits bitstream) 8))) (funcall (callback bitstream) (buffer bitstream) end) (setf (bits bitstream) 0))) (defmethod reset ((bitstream bitstream)) (fill (buffer bitstream) 0) (setf (bits bitstream) 0)) salza2-2.0.9/chains.lisp000066400000000000000000000056631217212514100150620ustar00rootroot00000000000000;;; ;;; Copyright (c) 2007 Zachary Beane, All Rights Reserved ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; (in-package #:salza2) (defun hash-value (input position) (+ (* #.+rmax+ (aref input position)) (* #.+radix+ (aref input (logand #.+input-mask+ (+ position 1)))) (aref input (logand #.+input-mask+ (+ position 2))))) (declaim (inline mod8191)) (defun mod8191 (z) (declare (type (integer 0 3057705) z)) (let ((zz (+ (ash z -13) (logand #x1FFF z)))) (if (< zz #x1FFF) zz (- zz #x1FFF)))) (defun update-chains (input hashes chains start count) (declare (type input-buffer input) (type hashes-buffer hashes) (type chains-buffer chains) (type input-index start) (type (integer 0 32768) count) (optimize speed)) (when (< count 3) (return-from update-chains)) (let* ((hash (hash-value input start)) (p0 start) (p1 (logand (+ start 2) #xFFFF))) (declare (type (integer 0 3057705) hash)) (loop (let ((hash-index (mod8191 hash))) ;; Stuff the old hash index into chains at p0 (setf (aref chains p0) (aref hashes hash-index)) ;; Stuff p0 into the hashes (setf (aref hashes hash-index) p0) ;; Tentatively advance; if we hit the end, don't do the rest of ;; the hash update (setf p1 (logand (1+ p1) #xFFFF)) (decf count) (when (= count 2) (return)) ;; We're not at the end, so lop off the high, shift left, and ;; add the low to form a new hash value (setf hash (- hash (* (aref input p0) 11881))) (setf hash (* hash 109)) (setf p0 (logand (1+ p0) #xFFFF)) (setf hash (+ hash (aref input p1))))))) salza2-2.0.9/checksum.lisp000066400000000000000000000036411217212514100154110ustar00rootroot00000000000000;;; ;;; Copyright (c) 2007 Zachary Beane, All Rights Reserved ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; (in-package #:salza2) (defclass checksum () ()) (defgeneric update (checksum buffer start count) (:documentation "Update the CHECKSUM object with COUNT octets from BUFFER, starting from START.")) (defgeneric result (checksum) (:documentation "Return the result of CHECKSUM as an integer.")) (defgeneric result-octets (checksum) (:documentation "Return the result of CHECKSUM as a list of octets, in MSB order.")) (defun ub32-octets (result) (list (ldb (byte 8 24) result) (ldb (byte 8 16) result) (ldb (byte 8 8) result) (ldb (byte 8 0) result))) salza2-2.0.9/closures.lisp000066400000000000000000000034551217212514100154510ustar00rootroot00000000000000;;; ;;; Copyright (c) 2007 Zachary Beane, All Rights Reserved ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; (in-package #:salza2) (defun make-huffman-writer (huffman-codes bitstream) (let ((codes (codes huffman-codes)) (sizes (sizes huffman-codes)) (buffer (buffer bitstream)) (callback (callback bitstream))) (lambda (value) (setf (bits bitstream) (merge-bits (aref codes value) (aref sizes value) buffer (bits bitstream) callback))))) salza2-2.0.9/compress.lisp000066400000000000000000000042701217212514100154410ustar00rootroot00000000000000;;; ;;; Copyright (c) 2007 Zachary Beane, All Rights Reserved ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; (in-package #:salza2) (defun compress (input chains start end literal-fun length-fun distance-fun) (declare (type input-buffer input) (type chains-buffer chains) (type input-index start end) (type function literal-fun length-fun distance-fun) (optimize speed)) (let ((p start)) (loop (when (= p end) (return)) (multiple-value-bind (length distance) (longest-match p input chains end 4) (declare (type (integer 0 258) length) (type (integer 0 32768) distance)) (cond ((zerop length) (funcall literal-fun (aref input p)) (setf p (logand (+ p 1) #xFFFF))) (t (funcall length-fun length) (funcall distance-fun distance) (setf p (logand (+ p length) #xFFFF)))))))) salza2-2.0.9/compressor.lisp000066400000000000000000000253621217212514100160070ustar00rootroot00000000000000;;; ;;; Copyright (c) 2007 Zachary Beane, All Rights Reserved ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; (in-package #:salza2) (defun make-input () (make-array 65536 :element-type 'octet)) (defun make-chains () (make-array 65536 :element-type '(unsigned-byte 16) :initial-element 0)) (defun make-hashes () (make-array +hashes-size+ :element-type '(unsigned-byte 16) :initial-element 0)) (defun error-missing-callback (&rest args) (declare (ignore args)) (error "No callback given for compression")) ;;; FIXME: MERGE-INPUT is pretty ugly. It's the product of incremental ;;; evolution and experimentation. It should be cleaned up. ;;; ;;; Its basic purpose is to use octets from INPUT to fill up 32k-octet ;;; halves of the 64k-octet OUTPUT buffer. Whenever a half fills up, ;;; the COMPRESS-FUN is invoked to compress that half. At the end, a ;;; partial half may remain uncompressed to be either filled by a ;;; future call to MERGE-INPUT or to get flushed out by a call to ;;; FINAL-COMPRESS. (defun merge-input (input start count output offset compress-fun) "Merge COUNT octets from START of INPUT into OUTPUT at OFFSET; on reaching 32k boundaries within OUTPUT, call the COMPRESS-FUN with OUTPUT, a starting offset, and the count of pending data." (declare (type octet-vector input output)) (let ((i start) (j (+ start (min count (- +input-limit+ (mod offset +input-limit+))))) (result (logand +buffer-size-mask+ (+ offset count)))) (dotimes (k (ceiling (+ (logand offset +input-limit-mask+) count) +input-limit+)) (when (plusp k) (funcall compress-fun output (logxor offset #x8000) +input-limit+)) (replace output input :start1 offset :start2 i :end2 j) (setf offset (logand +input-limit+ (+ offset +input-limit+))) (setf i j j (min (+ start count) (+ j +input-limit+)))) (when (zerop (logand result +input-limit-mask+)) (funcall compress-fun output (logxor offset #x8000) +input-limit+)) result)) (defun reinitialize-bitstream-funs (compressor bitstream) (setf (literal-fun compressor) (make-huffman-writer *fixed-huffman-codes* bitstream) (length-fun compressor) (make-huffman-writer *length-codes* bitstream) (distance-fun compressor) (make-huffman-writer *distance-codes* bitstream) (compress-fun compressor) (make-compress-fun compressor))) ;;; Class & protocol (defclass deflate-compressor () ((input :initarg :input :accessor input) (chains :initarg :chains :accessor chains) (hashes :initarg :hashes :accessor hashes) (start :initarg :start :accessor start) (end :initarg :end :accessor end) (counter :initarg :counter :accessor counter) (octet-buffer :initarg :octet-buffer :accessor octet-buffer) (bitstream :initarg :bitstream :accessor bitstream) (literal-fun :initarg :literal-fun :accessor literal-fun) (length-fun :initarg :length-fun :accessor length-fun) (distance-fun :initarg :distance-fun :accessor distance-fun) (byte-fun :initarg :byte-fun :accessor byte-fun) (compress-fun :initarg :compress-fun :accessor compress-fun)) (:default-initargs :input (make-input) :chains (make-chains) :hashes (make-hashes) :start 0 :end 0 :counter 0 :bitstream (make-instance 'bitstream) :octet-buffer (make-octet-vector 1))) ;;; Public protocol GFs (defgeneric start-data-format (compressor) (:documentation "Add any needed prologue data to the output bitstream.")) (defgeneric compress-octet (octet compressor) (:documentation "Add OCTET to the compressed data of COMPRESSOR.")) (defgeneric compress-octet-vector (vector compressor &key start end) (:documentation "Add the octets of VECTOR to the compressed data of COMPRESSOR.")) (defgeneric process-input (compressor input start count) (:documentation "Map over pending octets in INPUT and perform any needed processing. Called before the data is compressed. A subclass might use this to compute a checksum of all input data.")) (defgeneric finish-data-format (compressor) (:documentation "Add any needed epilogue data to the output bitstream.")) (defgeneric finish-compression (compressor) (:documentation "Finish the data format and flush all pending data in the bitstream.")) ;;; Internal GFs (defgeneric final-compress (compressor) (:documentation "Perform the final compression on pending input data in COMPRESSOR.")) (defgeneric make-compress-fun (compressor) (:documentation "Create a callback suitable for passing to MERGE-INPUT for performing incremental compression of the next 32k octets of input.")) ;;; Methods (defmethod initialize-instance :after ((compressor deflate-compressor) &rest initargs &key literal-fun length-fun distance-fun compress-fun callback) (declare (ignore initargs)) (let ((bitstream (bitstream compressor))) (setf (callback bitstream) (or callback #'error-missing-callback)) (setf (literal-fun compressor) (or literal-fun (make-huffman-writer *fixed-huffman-codes* bitstream))) (setf (length-fun compressor) (or length-fun (make-huffman-writer *length-codes* bitstream))) (setf (distance-fun compressor) (or distance-fun (make-huffman-writer *distance-codes* bitstream))) (setf (compress-fun compressor) (or compress-fun (make-compress-fun compressor))) (start-data-format compressor))) ;;; A few methods defer to the bitstream (defmethod (setf callback) (new-fun (compressor deflate-compressor)) (let ((bitstream (bitstream compressor))) (prog1 (setf (callback bitstream) new-fun) (reinitialize-bitstream-funs compressor bitstream)))) (defmethod write-bits (code size (compressor deflate-compressor)) (write-bits code size (bitstream compressor))) (defmethod write-octet (octet (compressor deflate-compressor)) (write-octet octet (bitstream compressor))) (defmethod write-octet-vector (vector (compressor deflate-compressor) &key (start 0) end) (write-octet-vector vector (bitstream compressor) :start start :end end)) (defmethod start-data-format ((compressor deflate-compressor)) (let ((bitstream (bitstream compressor))) (write-bits +final-block+ 1 bitstream) (write-bits +fixed-tables+ 2 bitstream))) (defmethod compress-octet (octet compressor) (let ((vector (octet-buffer compressor))) (setf (aref vector 0) octet) (compress-octet-vector vector compressor))) (defmethod compress-octet-vector (vector compressor &key (start 0) end) (let* ((closure (compress-fun compressor)) (end (or end (length vector))) (count (- end start))) (let ((end (merge-input vector start count (input compressor) (end compressor) closure))) (setf (end compressor) end (start compressor) (logand #x8000 end) (counter compressor) (logand #x7FFF end))))) (defmethod process-input ((compressor deflate-compressor) input start count) (update-chains input (hashes compressor) (chains compressor) start count)) (defmethod finish-data-format ((compressor deflate-compressor)) (funcall (literal-fun compressor) 256)) (defmethod finish-compression ((compressor deflate-compressor)) (final-compress compressor) (finish-data-format compressor) (flush (bitstream compressor))) (defmethod final-compress ((compressor deflate-compressor)) (let ((input (input compressor)) (chains (chains compressor)) (start (start compressor)) (end (end compressor)) (counter (counter compressor)) (literal-fun (literal-fun compressor)) (length-fun (length-fun compressor)) (distance-fun (distance-fun compressor))) (process-input compressor input start counter) (compress input chains start end literal-fun length-fun distance-fun))) (defmethod make-compress-fun ((compressor deflate-compressor)) (let ((literal-fun (literal-fun compressor)) (length-fun (length-fun compressor)) (distance-fun (distance-fun compressor))) (lambda (input start count) (process-input compressor input start count) (let ((end (+ start count))) (compress input (chains compressor) start (logand #xFFFF end) literal-fun length-fun distance-fun))))) (defmethod reset ((compressor deflate-compressor)) (fill (chains compressor) 0) (fill (input compressor) 0) (fill (hashes compressor) 0) (setf (start compressor) 0 (end compressor) 0 (counter compressor) 0) (reset (bitstream compressor)) (start-data-format compressor)) (defmacro with-compressor ((var class &rest initargs &key &allow-other-keys) &body body) `(let ((,var (make-instance ,class ,@initargs))) (multiple-value-prog1 (progn ,@body) (finish-compression ,var)))) salza2-2.0.9/crc32.lisp000066400000000000000000000070701217212514100145230ustar00rootroot00000000000000;;; ;;; Copyright (c) 2007 Zachary Beane, All Rights Reserved ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; (in-package #:salza2) (defun crc32-table () (let ((table (make-array 512 :element-type '(unsigned-byte 16)))) (dotimes (n 256 table) (let ((c n)) (declare (type (unsigned-byte 32) c)) (dotimes (k 8) (if (logbitp 0 c) (setf c (logxor #xEDB88320 (ash c -1))) (setf c (ash c -1))) (setf (aref table (ash n 1)) (ldb (byte 16 16) c) (aref table (1+ (ash n 1))) (ldb (byte 16 0) c))))))) (defvar *crc32-table* (crc32-table)) (defun crc32 (high low buf start count) (declare (type (unsigned-byte 16) high low) (type array-index start count) (type octet-vector buf) (optimize speed)) (let ((i start) (table *crc32-table*)) (declare (type array-index i) (type (simple-array (unsigned-byte 16) (*)) table)) (dotimes (j count (values high low)) (let ((index (logxor (logand low #xFF) (aref buf i)))) (declare (type (integer 0 255) index)) (let ((high-index (ash index 1)) (low-index (1+ (ash index 1)))) (declare (type (integer 0 511) high-index low-index)) (let ((t-high (aref table high-index)) (t-low (aref table low-index))) (declare (type (unsigned-byte 16) t-high t-low)) (incf i) (setf low (logxor (ash (logand high #xFF) 8) (ash low -8) t-low)) (setf high (logxor (ash high -8) t-high)))))))) ;;; Class interface (defclass crc32-checksum (checksum) ((low :initarg :low :accessor low) (high :initarg :high :accessor high)) (:default-initargs :low #xFFFF :high #xFFFF)) (defmethod update ((checksum crc32-checksum) input start count) (setf (values (high checksum) (low checksum)) (crc32 (high checksum) (low checksum) input start count))) (defmethod result ((checksum crc32-checksum)) (+ (ash (logxor (high checksum) #xFFFF) 16) (logxor (low checksum) #xFFFF))) (defmethod result-octets ((checksum crc32-checksum)) (ub32-octets (result checksum))) (defmethod reset ((checksum crc32-checksum)) (setf (low checksum) #xFFFF (high checksum) #xFFFF)) salza2-2.0.9/doc/000077500000000000000000000000001217212514100134575ustar00rootroot00000000000000salza2-2.0.9/doc/COPYING.txt000066400000000000000000000025231217212514100153320ustar00rootroot00000000000000;;; ;;; Copyright (c) 2007 Zachary Beane, All Rights Reserved ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; salza2-2.0.9/doc/index.html000066400000000000000000000377031217212514100154660ustar00rootroot00000000000000 Salza2 - Create compressed data from Common Lisp

Salza2 - Create compressed data from Common Lisp

Abstract

Salza2 is a Common Lisp library for creating compressed data in the ZLIB, DEFLATE, or GZIP data formats, described in RFC 1950, RFC 1951, and RFC 1952, respectively. It does not use any external libraries for compression. It does not yet support decompression. Salza2 is available under a BSD-like license. The latest version is 2.0.9, released on July 18th, 2013.

Download shortcut:

http://www.xach.com/lisp/salza2.tgz

Contents

  1. Overview and Limitations
  2. Dictionary
  3. References
  4. Acknowledgements
  5. Feedback

Overview and Limitations

Salza2 provides an interface for creating a compressor object. This object acts as a sink for octets (either individual octets or vectors of octets), and is a source for octets in a compressed data format. The compressed octet data is provided to a user-defined callback that can write it to a stream, copy it to another vector, etc.

Salza2 has built-in compressors that support the ZLIB, DEFLATE, and GZIP data formats. The classes and generic function protocol are available to make it easy to support similar formats via subclassing and new methods. ZLIB and GZIP are extensions to the DEFLATE format and are implemented as subclasses of DEFLATE-COMPRESSOR with a few methods implemented for the protocol.

Salza2 is the successor to Salza, but it is not backwards-compatible. Among other changes, Salza2 drops support for compressing Lisp character data, since the compression formats are octet-based and obtaining encoded octets from Lisp characters varies from implementation to implementation.

There are a number of functions that provide a simple interface to specific tasks such as gzipping a file or compressing a single vector.

Salza2 does not decode compressed data. There is no support for dynamically defined Huffman codes. There is currently no interface for changing the tradeoff between compression speed and compressed data size.

Dictionary

The following symbols are exported from the SALZA2 package.

Standard Compressors

[Classes]
deflate-compressor
zlib-compressor
gzip-compressor

Instances of these classes may be created via make-instance. The only supported initarg is :CALLBACK. See CALLBACK for the expected value.

[Accessor]
callback compressor => callback
(setf (callback compressor) new-value) => new-value

Gets or sets the callback function of compressor. The callback should be a function of two arguments, an octet vector and an end index, and it should process all octets from the start of the vector below the end index as the compressed output data stream of the compressor. See MAKE-STREAM-OUTPUT-CALLBACK for an example callback.

[Function]
compress-octet octet compressor => |

Adds octet to compressor to be compressed.

[Function]
compress-octet-vector vector compressor &key start end => |

Adds the octets from vector to compressor to be compressed, beginning with the octet at start and ending at the octet at end - 1. If start is not specified, it defaults to 0. If end is not specified, it defaults to the total length of vector. Equivalent to (but much more efficient than) the following: 
(loop for i from start below end
      do (compress-octet (aref vector i) compressor))

[Generic function]
finish-compression compressor => |

Compresses any pending data, concludes the data format for compressor with FINISH-DATA-FORMAT, and invokes the user callback for the final octets of the compressed data format. This function must be called at the end of compression to ensure the validity of the data format; it is called implicitly by WITH-COMPRESSOR.

[Generic function]
reset compressor => |

The default method for DEFLATE-COMPRESSOR objects resets the internal state of compressor and calls START-DATA-FORMAT. This allows the re-use of a single compressor object for multiple compression tasks.

[Macro]
with-compressor (var class &rest initargs &key &allow-other-keys) &body body => |

Evaluates body with var bound to a new compressor created as with (apply #'make-instance class initargs). FINISH-COMPRESSION is implicitly called on the compressor at the end of evaluation.

Customizing Compressors

Compressor objects follow a protocol that makes it easy to create specialized data formats. The ZLIB data format is essentially the same as the DEFLATE format with an additional header and a trailing checksum; this is implemented by creating a new class and adding a few new methods to the generic functions below.

For example, consider a new compressed data format FOO that encapsulates a DEFLATE data stream but adds four signature octets, F0 0D 00 D1, to the start of the output data stream, and adds a trailing 32-bit length value, MSB first, after the end. It could be implemented like this: 

(defclass foo-compressor (deflate-compressor)
  ((data-length
    :initarg :data-length
    :accessor data-length))
  (:default-initargs
   :data-length 0))

(defmethod start-data-format :before ((compressor foo-compressor))
  (write-octet #xF0 compressor)
  (write-octet #x0D compressor)
  (write-octet #x00 compressor)
  (write-octet #xD1 compressor))

(defmethod process-input :after ((compressor foo-compressor) input start count)
  (declare (ignore input start))
  (incf (data-length compressor) count))

(defmethod finish-data-format :after ((compressor foo-compressor))
  (let ((length (data-length compressor)))
    (write-octet (ldb (byte 8 24) length) compressor)
    (write-octet (ldb (byte 8 16) length) compressor)
    (write-octet (ldb (byte 8  8) length) compressor)
    (write-octet (ldb (byte 8  0) length) compressor)))

(defmethod reset :after ((compressor foo-compressor))
  (setf (data-length compressor) 0))

[Function]
write-bits code size compressor => |

Writes size low bits of the integer code to the output buffer of compressor. Follows the bit packing layout described in RFC 1951. The bits are not compressed, but become literal parts of the output stream.

[Function]
write-octet octet compressor => |

Writes octet to the output buffer of compressor. Bits of the octet are not packed; the octet is added to the output buffer at the next octet boundary. The octet is not compressed, but becomes a literal part of the output stream.

[Generic function]
start-data-format compressor => |

Outputs any prologue bits or octets needed to produce a valid compressed data stream for compressor. Called from initialize-instance and RESET for subclasses of deflate-compressor. Should not be called directly, but subclasses may add methods to customize what literal data is added to the beginning of the output buffer.

[Generic function]
process-input compressor input start count => |

Called when count octets of the octet vector input, starting from start, are about to be compressed. This generic function should not be called directly, but may be specialized.

This is useful for data formats that must maintain information about the uncompressed contents of a compressed data stream, such as checksums or total data length.

[Generic function]
finish-data-format compressor => |

Called by FINISH-COMPRESSION. Outputs any epilogue bits or octets needed to produce a valid compressed data stream for compressor. This generic function should not be called directly, but may be specialized.

Checksums

Checksums are used in several data formats to check data integrity. For example, PNG uses a CRC32 checksum for its chunks of data. Salza2 exports support for two common checksums.

[Standard classes]
adler32-checksum
crc32-checksum

Instances of these classes may be created directly with make-instance.

[Generic function]
update checksum buffer start count => |

Updates checksum with count octets from the octet vector buffer, starting at start.

[Generic function]
result checksum => result

Returns the accumulated value of checksum as an integer.

[Generic function]
result-octets checksum => result-list

Returns the individual octets of checksum as a list of octets, in MSB order.

[Generic function]
reset checksum => |

The default method for checksum objects resets the internal state of checksum so it may be re-used.

Shortcuts

Some shortcuts for common compression tasks are available.

[Function]
make-stream-output-callback stream => callback>

Creates and returns a callback function that writes all compressed data to stream. It is defined like this: 
(defun make-stream-output-callback (stream)
  (lambda (buffer end)
    (write-sequence buffer stream :end end)))

[Function]
gzip-stream input-stream output-stream => |

Compresses all data read from input-stream and writes the compressed data to output-stream.

[Function]
gzip-file input-file output-file => pathname

Compresses input-file and writes the compressed data to output-file.

[Function]
compress-data data compressor-designator &rest initargs => compressed-data

Compresses the octet vector data and returns the compressed data as an octet vector. compressor-designator should be either a compressor object, designating itself, or a symbol, designating a compressor created as with (apply #'make-instance compressor-designator initargs).

For example: 

* (compress-data (sb-ext:string-to-octets "Hello, hello, hello, hello world.") 
                 'zlib-compressor)
#(8 153 243 72 205 201 201 215 81 200 192 164 20 202 243 139 114 82 244 0 194 64 11 139)

References

Acknowledgements

Thanks to Paul Khuong for his help optimizing the modulo-8191 hashing.

Thanks to Austin Haas for providing some test SWF files demonstrating a data format bug.

Feedback

Please direct any comments, questions, bug reports, or other feedback to Zach Beane. salza2-2.0.9/gzip.lisp000066400000000000000000000063661217212514100145670ustar00rootroot00000000000000;;; ;;; Copyright (c) 2007 Zachary Beane, All Rights Reserved ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; (in-package #:salza2) (defvar *gzip-signature* (octet-vector #x1F #x8B) "These two octets precede all data in the gzip format.") (defconstant +gzip-fast-compression+ 4 "Code for gzip compression level. This is present only to create valid gzip data; it has no meaning to the compressor and is only a hint to the decompressor.") ;;; These are all used to create valid files, not to control or modify ;;; the compression process. (defconstant +gzip-deflate-compression+ 8) (defconstant +gzip-flags+ 0) (defconstant +gzip-unix-os+ 3) (defconstant +gzip-mtime+ 0) (defun gzip-write-u32 (value compressor) ;; LSB (write-octet (ldb (byte 8 0) value) compressor) (write-octet (ldb (byte 8 8) value) compressor) (write-octet (ldb (byte 8 16) value) compressor) (write-octet (ldb (byte 8 24) value) compressor)) (defclass gzip-compressor (deflate-compressor) ((checksum :initarg :checksum :accessor checksum) (data-length :initarg :data-length :accessor data-length)) (:default-initargs :checksum (make-instance 'crc32-checksum) :data-length 0)) (defmethod start-data-format :before ((compressor gzip-compressor)) (write-octet-vector *gzip-signature* compressor) (write-octet +gzip-deflate-compression+ compressor) (write-octet +gzip-flags+ compressor) (gzip-write-u32 +gzip-mtime+ compressor) (write-octet +gzip-fast-compression+ compressor) (write-octet +gzip-unix-os+ compressor)) (defmethod process-input :after ((compressor gzip-compressor) input start count) (incf (data-length compressor) count) (update (checksum compressor) input start count)) (defmethod finish-data-format :after ((compressor gzip-compressor)) (gzip-write-u32 (result (checksum compressor)) compressor) (gzip-write-u32 (data-length compressor) compressor)) (defmethod reset :after ((compressor gzip-compressor)) (reset (checksum compressor)) (setf (data-length compressor) 0)) salza2-2.0.9/huffman.lisp000066400000000000000000000117111217212514100152300ustar00rootroot00000000000000;;; ;;; Copyright (c) 2007 Zachary Beane, All Rights Reserved ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; (in-package #:salza2) (deftype code-vector () '(simple-array (unsigned-byte 32) (*))) (deftype size-vector () '(simple-array (unsigned-byte 8) (*))) (defclass huffman-codes () ((codes :initarg :codes :accessor codes) (sizes :initarg :sizes :accessor sizes))) (defun code-vector (length) (make-array length :element-type '(unsigned-byte 32))) (defun size-vector (length) (make-array length :element-type '(unsigned-byte 8))) ;;; ;;; Generate the fixed code/size vectors ;;; (defun reverse-bits (word n) (let ((j 0)) (dotimes (i n j) (setf j (logior (ash j 1) (logand #x1 word))) (setf word (ash word -1))))) (defun fixed-huffman-codes () "Generate the fixed Huffman codes specified by RFC1951." (let ((codes (code-vector 288)) (sizes (size-vector 288)) (i 0)) (flet ((fill-range (length start end) (loop for j from start to end do (setf (aref codes i) (reverse-bits j length) (aref sizes i) length) (incf i)))) (fill-range 8 #b00110000 #b10111111) (fill-range 9 #b110010000 #b111111111) (fill-range 7 #b0000000 #b0010111) (fill-range 8 #b11000000 #b11000111) (make-instance 'huffman-codes :codes codes :sizes sizes)))) (defun length-codes (huffman-codes) "Compute a table of the (Huffman + extra bits) values for all possible lengths for the given HUFFMAN-TABLE." (let ((codes (code-vector 259)) (sizes (size-vector 259)) (code 257) (length 3) (extra-bit-counts '(0 0 0 0 0 0 0 0 1 1 1 1 2 2 2 2 3 3 3 3 4 4 4 4 5 5 5 5 0))) (labels ((save-pair (i code size) (setf (aref codes i) code (aref sizes i) size)) (save-value (extra-bit-count extra-value) (let ((huffman-value (aref (codes huffman-codes) code)) (huffman-count (aref (sizes huffman-codes) code))) (save-pair length (logior huffman-value (ash extra-value huffman-count)) (+ huffman-count extra-bit-count))))) (dolist (count extra-bit-counts) (dotimes (i (expt 2 count)) (when (< length 258) (save-value count i) (incf length))) (incf code)) (setf code 285) (save-value 0 0)) (make-instance 'huffman-codes :codes codes :sizes sizes))) (defun distance-codes () "Compute a table of the (code + extra bits) values for all possible distances as specified by RFC1951." (let ((codes (code-vector 32769)) (sizes (size-vector 32769)) (code 0) (distance 1) (extra-bit-counts '(0 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 10 10 11 11 12 12 13 13))) (flet ((save-value (extra-bit-count extra-value) (setf (aref codes distance) (logior (ash extra-value 5) (reverse-bits code 5)) (aref sizes distance) (+ 5 extra-bit-count)))) (dolist (count extra-bit-counts) (dotimes (i (expt 2 count)) (save-value count i) (incf distance)) (incf code))) (make-instance 'huffman-codes :codes codes :sizes sizes))) (defvar *fixed-huffman-codes* (fixed-huffman-codes)) (defvar *length-codes* (length-codes *fixed-huffman-codes*)) (defvar *distance-codes* (distance-codes)) salza2-2.0.9/matches.lisp000066400000000000000000000063171217212514100152360ustar00rootroot00000000000000;;; ;;; Copyright (c) 2007 Zachary Beane, All Rights Reserved ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; (in-package #:salza2) (defconstant +maximum-match-length+ 258 "The maximum match length allowed.") (defconstant +maximum-match-distance+ 32768 "The maximum distance for a match.") (declaim (inline match-length)) (defun match-length (p1 p2 input end) "Returns the length of the match between positions p1 and p2 in INPUT; END is a sentinel position that ends the match length check if reached." (declare (type input-index p1 p2 end) (type input-buffer input) (optimize speed)) (let ((length 0)) (loop (when (or (/= (aref input p1) (aref input p2)) (= length +maximum-match-length+) (= p1 end)) (return length)) (setf p1 (logand (1+ p1) #xFFFF) p2 (logand (1+ p2) #xFFFF) length (logand #xFFF (1+ length)))))) (defun longest-match (p1 input chains end max-tests) (declare (type input-index p1 end) (type input-buffer input) (type chains-buffer chains) (type (integer 0 32) max-tests) (optimize speed)) (let ((match-length 0) (p2 (aref chains p1)) (test-count 0) (distance 0)) (declare (type (integer 0 258) match-length) (type (integer 0 32) test-count)) (loop (when (or (= match-length +maximum-match-length+) (= test-count max-tests) (= p2 p1) (= p2 (aref chains p2))) (return (values match-length distance))) (let ((step (logand (- p1 p2) #xFFFF))) (when (< +maximum-match-distance+ step) (return (values match-length distance))) (let ((possible-length (match-length p1 p2 input end))) (when (and (< 2 possible-length) (< match-length possible-length)) (setf distance step match-length possible-length)) (setf p2 (aref chains p2))) (incf test-count))))) salza2-2.0.9/package.lisp000066400000000000000000000036521217212514100152040ustar00rootroot00000000000000;;; ;;; Copyright (c) 2007 Zachary Beane, All Rights Reserved ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; (defpackage #:salza2 (:use #:cl) (:export ;; misc #:reset ;; compressor #:deflate-compressor #:callback #:write-bits #:write-octet #:write-octet-vector #:start-data-format #:compress-octet #:compress-octet-vector #:process-input #:finish-data-format #:finish-compression #:with-compressor ;; zlib #:zlib-compressor ;; gzip #:gzip-compressor ;; checksum #:update #:result #:result-octets #:adler32-checksum #:crc32-checksum ;; user #:make-stream-output-callback #:gzip-stream #:gzip-file #:compress-data)) salza2-2.0.9/reset.lisp000066400000000000000000000027201217212514100147260ustar00rootroot00000000000000;;; ;;; Copyright (c) 2007 Zachary Beane, All Rights Reserved ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; (in-package #:salza2) (defgeneric reset (object) (:documentation "Restore OBJECT's initial state so it may be re-used.")) salza2-2.0.9/salza2.asd000066400000000000000000000076401217212514100146060ustar00rootroot00000000000000;;; ;;; Copyright (c) 2007 Zachary Beane, All Rights Reserved ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; (asdf:defsystem #:salza2 :author "Zachary Beane " :license "BSD" :version "2.0.9" :description "Create compressed data in the ZLIB, DEFLATE, or GZIP data formats" :components ((:file "package") (:file "reset" :depends-on ("package")) (:file "specials" :depends-on ("package")) (:file "types" :depends-on ("package" "specials")) (:file "checksum" :depends-on ("package" "reset")) (:file "adler32" :depends-on ("checksum" "types")) (:file "crc32" :depends-on ("checksum" "types")) (:file "chains" :depends-on ("package" "specials")) (:file "bitstream" :depends-on ("package" "specials" "reset")) (:file "matches" :depends-on ("package" "types")) (:file "compress" :depends-on ("types" "matches")) (:file "huffman" :depends-on ("package")) (:file "closures" :depends-on ("huffman" "bitstream")) (:file "compressor" :depends-on ("package" "closures" "utilities" "specials" "bitstream" "reset")) (:file "utilities" :depends-on ("package")) (:file "zlib" :depends-on ("package" "adler32" "reset" "compressor")) (:file "gzip" :depends-on ("package" "crc32" "reset" "compressor")) (:file "user" :depends-on ("package" "compressor" "zlib" "gzip")))) salza2-2.0.9/specials.lisp000066400000000000000000000040301217212514100154030ustar00rootroot00000000000000;;; ;;; Copyright (c) 2007 Zachary Beane, All Rights Reserved ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; (in-package #:salza2) (defparameter +input-limit+ 32768) (defparameter +input-limit-mask+ (1- +input-limit+)) (defparameter +buffer-size+ (* +input-limit+ 2)) (defparameter +buffer-size-mask+ (1- +buffer-size+)) (defparameter +input-size+ #x10000) (defparameter +input-mask+ #x0FFFF) (defparameter +hashes-size+ 8191) (defparameter +radix+ 109) (defparameter +rmax+ (* +radix+ +radix+)) (defparameter +bitstream-buffer-size+ 4096) (defparameter +bitstream-buffer-mask+ (1- +bitstream-buffer-size+)) (defparameter +bitstream-buffer-bits+ (* +bitstream-buffer-size+ 8)) (defparameter +bitstream-buffer-bitmask+ (1- +bitstream-buffer-bits+)) (defconstant +final-block+ #b1) (defconstant +fixed-tables+ #b01) salza2-2.0.9/types.lisp000066400000000000000000000040211217212514100147440ustar00rootroot00000000000000;;; ;;; Copyright (c) 2007 Zachary Beane, All Rights Reserved ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; (in-package #:salza2) (deftype array-index () `(mod ,array-dimension-limit)) (deftype octet () '(unsigned-byte 8)) (deftype octet-vector () '(simple-array (unsigned-byte 8) (*))) (deftype input-index () '(unsigned-byte 16)) (deftype input-buffer () `(simple-array (unsigned-byte 8) (,+input-size+))) (deftype chains-buffer () `(simple-array (unsigned-byte 16) (,+input-size+))) (deftype hashes-buffer () `(simple-array (unsigned-byte 16) (,+hashes-size+))) (deftype hash () `(integer 0 ,+hashes-size+)) (deftype bitstream-buffer () `(simple-array (unsigned-byte 8) (,+bitstream-buffer-size+))) (deftype bitstream-buffer-bit-count () `(integer 0 ,+bitstream-buffer-bits+)) salza2-2.0.9/user.lisp000066400000000000000000000064121217212514100145640ustar00rootroot00000000000000;;; ;;; Copyright (c) 2007 Zachary Beane, All Rights Reserved ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; (in-package #:salza2) (defun make-stream-output-callback (stream) "Return a function suitable for use as a compressor callback that writes all compressed data to STREAM." (lambda (buffer end) (write-sequence buffer stream :end end))) (defun gzip-stream (input output) (let ((callback (make-stream-output-callback output)) (buffer (make-array 8192 :element-type '(unsigned-byte 8)))) (with-compressor (compressor 'gzip-compressor :callback callback) (loop (let ((end (read-sequence buffer input))) (when (zerop end) (return)) (compress-octet-vector buffer compressor :end end)))))) (defun gzip-file (input output &key (if-exists :supersede)) (with-open-file (istream input :element-type '(unsigned-byte 8)) (with-open-file (ostream output :element-type '(unsigned-byte 8) :direction :output :if-exists if-exists) (gzip-stream istream ostream))) (probe-file output)) (defun compressor-designator-compressor (designator initargs) (etypecase designator (symbol (apply #'make-instance designator initargs)) (deflate-compressor designator))) (defun compress-data (data compressor-designator &rest initargs) (let ((chunks '()) (size 0) (compressor (compressor-designator-compressor compressor-designator initargs))) (setf (callback compressor) (lambda (buffer end) (incf size end) (push (subseq buffer 0 end) chunks))) (compress-octet-vector data compressor) (finish-compression compressor) (let ((compressed (make-array size :element-type '(unsigned-byte 8))) (start 0)) (dolist (chunk (nreverse chunks)) (replace compressed chunk :start1 start) (incf start (length chunk))) compressed))) salza2-2.0.9/utilities.lisp000066400000000000000000000031101217212514100156110ustar00rootroot00000000000000;;; ;;; Copyright (c) 2007 Zachary Beane, All Rights Reserved ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; (in-package #:salza2) (defun make-octet-vector (size) (make-array size :element-type 'octet)) (defun octet-vector (&rest elements) (make-array (length elements) :element-type 'octet :initial-contents elements)) salza2-2.0.9/zlib.lisp000066400000000000000000000041771217212514100145540ustar00rootroot00000000000000;;; ;;; Copyright (c) 2007 Zachary Beane, All Rights Reserved ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; ;;; * Redistributions in binary form must reproduce the above ;;; copyright notice, this list of conditions and the following ;;; disclaimer in the documentation and/or other materials ;;; provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; (in-package #:salza2) (defclass zlib-compressor (deflate-compressor) ((adler32 :initarg :adler32 :accessor adler32)) (:default-initargs :adler32 (make-instance 'adler32-checksum))) (defmethod start-data-format :before ((compressor zlib-compressor)) ;; FIXME: Replace these naked constants with symbolic constants. (write-octet #x78 compressor) (write-octet #x9C compressor)) (defmethod process-input :after ((compressor zlib-compressor) input start count) (let ((checksum (adler32 compressor))) (update checksum input start count))) (defmethod finish-data-format :after ((compressor zlib-compressor)) (dolist (octet (result-octets (adler32 compressor))) (write-octet octet compressor))) (defmethod reset :after ((compressor zlib-compressor)) (reset (adler32 compressor)))