pax_global_header00006660000000000000000000000064107601215770014520gustar00rootroot0000000000000052 comment=cc42e872a1e9e1fe2c7598b00379c6dff27484a4 cl-salza-0.7.4/000077500000000000000000000000001076012157700132365ustar00rootroot00000000000000cl-salza-0.7.4/ChangeLog000066400000000000000000000064121076012157700150130ustar00rootroot000000000000002007-03-07 Zach Beane * Made 0.7.4 release. * examples/png.lisp: Remove some work-in-progress cruft. 2007-03-06 Zach Beane * Made 0.7.3 release. * deflate-stream-interface.lisp (string-to-octets): Use custom:*default-file-encoding* when converting a string to octets on CLISP. * zlib.lisp (zlib-write-string): Don't bypass zlib-write-sequence; it's where the adler32 checksum is maintained. Thanks to Jason S. Cornez for noticing the bug. 2005-04-28 Zach Beane * Made 0.7.2 release. * Fixed flush-deflate-stream; when running past the end of the buffer, call the callback instead of looping forever doing nothing. Bug reported by Yannick Gingras. 2005-04-05 Zach Beane * Made 0.7.1 release. * Fixed adler32 not to croak when (>= start end). Thanks to Edi Weitz via David Lichteblau. 2005-04-01 Zach Beane * Made 0.7 release. * Made adler32 faster by working with the crc in two halves and only applying the mod every 16 rounds. * Fixed the buffer-offset declaration; array-total-size-limit and array-dimension-limit differ by a large margin on LispWorks, and they are exclusive bounds. * Exported zlib-stream-buffer. * Fixed declarations in (and slightly rearranged) the fixhash functions; fixhashes no longer segfault or fill up unexpectedly. * Added new octet-vector type and used it where appropriate. 2005-03-22 Zach Beane * Made 0.6 release. * Very minor optimization declaration updates. 2005-03-20 Zach Beane * Made 0.5 release * Changed declarations in many places; I mistakenly thought (simple-array foo) was the same as (simple-array foo (*)). It's not. Also added declarations where possible. * Changed bit-writing functions to close over simple-vectors of code and extra bits values, rather than packing things into a single integer. * Switched to a customized hash table implementation. * Switched to a customized implementation of REPLACE for octets. * Switched to LET binding instead of SYMBOL-MACROLET in a few places. * Switched to LOGAND and SHIFT in some places where LDB was used. * Switched to an (unsigned-byte 16) implementation of CRC32 to avoid bignums. 2005-03-17 Zach Beane * Made 0.4 release. * zlib.lisp (compress-sequence): Fixed compress-string's interaction with the callback; removed the buggy assumption that all calls except the last will be on full buffers. * Made another silent 0.3 rerelease. How long can I go without anyone noticing? * zlib.lisp (compress-string): Changed call from ZLIB:COMPRESS to the newly-renamed ZLIB:COMPRESS-SEQUENCE. 2005-03-16 Zach Beane * Silently re-release 0.3 with brown paper bag on head. * deflate-stream-interface.lisp (string-to-octets): Switch the order of START and END when calculating the size of the result sequence. * Made 0.3 release. * Renamed ZLIB:COMPRESS to ZLIB:COMPRESS-SEQUENCE. * Switched to a system of callbacks for handling full buffers; the condition system is used as a default if no callbacks are provided. * Added ZLIB:COMPRESS-STREAM. * Export ZLIB:ZLIB-STREAM-CALLBACK and DEFLATE:DEFLATE-STREAM-CALLBACK. * Fix embarrassing off-by-one error in DEFLATE::STRING-TO-OCTETS. cl-salza-0.7.4/LICENSE000066400000000000000000000024361076012157700142500ustar00rootroot00000000000000Salza, a Common Lisp library for data compression. Copyright (c) 2005 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. cl-salza-0.7.4/README000066400000000000000000000053551076012157700141260ustar00rootroot00000000000000Salza ----- The salza home page is: http://www.xach.com/lisp/salza/ Visit that page for software updates and documentation. Salza is an implementation of the DEFLATE compressed data format, described in RFC 1951, and the ZLIB compressed data format, described in RFC 1950. Currently, only output is supported. Brief documentation is below; more is coming. See also examples/png.lisp and examples/gzip.lisp for uses of the interfaces for DEFLATE and ZLIB functionality. ZLIB API Overview ----------------- All functions are in the SALZA package, which has a nickname of ZLIB. In general: - create a backing buffer; compressed data will be output to this buffer one or more bytes at a time - create a callback function; it will be called when the backing buffer is full and at the end of compression - create a zlib-stream object that references the backing buffer and the callback - use the zlib-write-sequence and zlib-write-string functions to write uncompressed data into the zlib-stream - call finish-zlib-stream to finish compression The callback function is called with the zlib-stream object as its only argument. Since the callback function may be called when the zlib-stream buffer is not full, zlib-stream-position should be used to determine the index after the last compressed byte in the buffer. Here is the implementation of COMPRESS-STREAM from zlib.lisp: (defun compress-stream (input output) "Read input from the stream INPUT and write it in ZLIB format to the stream OUTPUT. Both streams must have element-types of '(unsigned-byte 8)." (flet ((flush-stream (zlib-stream) (write-sequence (zlib-stream-buffer zlib-stream) output :end (zlib-stream-position zlib-stream)) (setf (zlib-stream-position zlib-stream) 0))) (let* ((input-buffer (make-array 8192 :element-type 'octet)) (output-buffer (make-array 8192 :element-type 'octet)) (zlib-stream (make-zlib-stream output-buffer :callback #'flush-stream))) (loop (let ((end (read-sequence input-buffer input))) (zlib-write-sequence input-buffer zlib-stream :end end) (when (zerop end) (finish-zlib-stream zlib-stream) (return))))))) In this case, the local variable OUTPUT-BUFFER is the backing buffer and the local function FLUSH-STREAM is the callback. Data is read from the stream INPUT into the array INPUT-BUFFER and then written to the zlib-stream with ZLIB-WRITE-SEQUENCE. When there is no more data (READ-SEQUENCE returned zero), FINISH-ZLIB-STREAM finishes up compression and may call the callback function one or more times in the process. cl-salza-0.7.4/compressor.lisp000066400000000000000000000127751076012157700163370ustar00rootroot00000000000000;;; ;;; compressor.lisp ;;; ;;; Created: 2005-03-12 by Zach Beane ;;; ;;; Copyright (c) 2005 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. ;;; ;;; $Id: compressor.lisp,v 1.13 2005/04/01 21:59:25 xach Exp $ (in-package :salza-deflate) (defun compress (deflate-stream) "Compress pending input in DEFLATE-STREAM to its output buffer." (declare (optimize (speed 3) (safety 0) (debug 0)) (type deflate-stream deflate-stream)) (let* ((input (deflate-stream-compress-buffer deflate-stream)) (positions (deflate-stream-compress-positions deflate-stream)) (i 0) (j 0) (length 0) (distance 0) (end (min (deflate-stream-compress-pos deflate-stream) (length input))) (trigram 0)) (declare (type octet-vector input) (type buffer-offset i j end) (type (integer 0 32768) distance) (type (integer 0 258) length) (type (integer 0 #xFFFFFF) trigram)) (labels ((save-trigram () (setf (getfixhash trigram positions) i)) (shift-in () (setf trigram (logior (ash (logand #xFFFF trigram) 8) (aref input i))) (incf i)) (output-literal () (write-literal (ash (logand #xFF0000 trigram) -16) deflate-stream)) (output-length/distance (length distance) (write-length length deflate-stream) (write-distance distance deflate-stream))) (declare (inline save-trigram shift-in output-literal output-length/distance)) (when (< end 4) (dotimes (k end) (write-literal (aref input k) deflate-stream)) (return-from compress)) (shift-in) (shift-in) (shift-in) (tagbody loop (setf j (getfixhash trigram positions)) (when (or (zerop j) (> (- i j) 32768)) (output-literal) (save-trigram) (when (= i end) (write-literal (ash (logand #xFF00 trigram) -8) deflate-stream) (write-literal (logand #xFF trigram) deflate-stream) (return-from compress)) (shift-in) (go loop)) (setf length 3 distance (- i j)) match-loop (when (and (< i end) (= (aref input i) (aref input j)) (< length 258)) (save-trigram) (shift-in) (incf j) (incf length) (go match-loop)) (output-length/distance length distance) (cond ((= i end) (return-from compress)) ((> (+ 3 i) end) (dotimes (k (- end i)) (write-literal (aref input (+ k i)) deflate-stream)) (return-from compress))) (dotimes (k 3) (save-trigram) (shift-in)) (go loop))))) (defun compress-input (deflate-stream) "Output the pending input of DEFLATE-STREAM to its bitstream. Resets the position cache." (compress deflate-stream) (clrfixhash (deflate-stream-compress-positions deflate-stream)) (setf (deflate-stream-compress-pos deflate-stream) 0)) (defun compress-sequence (sequence deflate-stream start end) "Add the octet sequence SEQUENCE to DEFLATE-STREAM. May signal a continuable error of type DEFLATE-STREAM-BUFFER-FULL." (symbol-macrolet ((pos (deflate-stream-compress-pos deflate-stream)) (buffer (deflate-stream-compress-buffer deflate-stream))) (let ((space-left (- (length buffer) pos))) (loop (octet-replace buffer sequence pos *compressor-buffer-size* start (min end (+ start space-left))) (cond ((<= space-left (- end start)) (incf start space-left) (incf pos space-left) (compress-input deflate-stream) (setf space-left (- (length buffer) pos))) (t (incf pos (- end start)) (return))))))) (defun finish-compress (deflate-stream) "Write out any pending input in COMPRESSOR to its bitstream. May signal BITSTREAM-BUFFER-FULL." (compress-input deflate-stream)) cl-salza-0.7.4/deflate-stream-interface.lisp000066400000000000000000000137651076012157700207760ustar00rootroot00000000000000;;; ;;; deflate-stream-interface.lisp ;;; ;;; Created: 2005-03-14 by Zach Beane ;;; ;;; Copyright (c) 2005 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. ;;; ;;; $Id: deflate-stream-interface.lisp,v 1.11 2006/02/03 15:34:33 xach Exp $ (in-package :salza-deflate) (defun start-deflate-stream (deflate-stream) ;; The block header ;; BFINAL is always set, since right now dynamic codes are not ;; supported so we never need to start a new block (write-bits 1 1 deflate-stream) (write-bits +deflate-fixed-tables-code+ 2 deflate-stream)) (defun finish-deflate-stream (deflate-stream) "Compress any pending input in the deflate-stream to its internal buffer and add the end-of-block code." (finish-compress deflate-stream) (write-literal #x100 deflate-stream) (flush-deflate-stream deflate-stream) (funcall (deflate-stream-callback deflate-stream) deflate-stream)) (defun deflate-write-sequence (sequence deflate-stream &key (start 0) (end (length sequence))) (compress-sequence sequence deflate-stream start end)) (defun deflate-write-byte (octet deflate-stream) "Finish any pending byte in the deflate stream and write BYTE as the next octet to DEFLATE-STREAM." (flush-deflate-stream deflate-stream) (write-bits octet 8 deflate-stream)) (eval-when (:compile-toplevel :load-toplevel :execute) (when (<= char-code-limit 256) (pushnew :octet-characters *features*))) (defun string-to-octets (string start end) "Convert STRING to a sequence of octets, if possible." (declare (type string string) (type buffer-offset start end) (optimize (speed 3) (safety 0))) #+(and sbcl (not octet-characters)) (sb-ext:string-to-octets string :start start :end end) #+(and allegro (not octet-characters)) (excl:string-to-octets string :start start :end end :null-terminate nil) #+(and clisp (not octet-characters)) (ext:convert-string-to-bytes string custom:*default-file-encoding* :start start :end end) #+(or octet-characters lispworks) (let* ((length (- end start)) (result (make-array length :element-type 'octet))) (loop for i fixnum from start below end for j fixnum from 0 do (setf (aref result j) (char-code (aref string i)))) result) #+(and (not octet-characters) (not (or sbcl allegro clisp lispworks))) (error "Do not know how to convert a string to octets.")) (defun deflate-write-string (string deflate-stream &key (start 0) (end (length string))) (deflate-write-sequence (string-to-octets string start end) deflate-stream)) ;;; CRC32 (defun crc32-table () (declare (optimize (speed 3) (safety 0))) (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))))))) (let ((table (crc32-table))) (defun crc32 (high low buf end) (declare (optimize (speed 3) (safety 0) #+lispworks (hcl:fixnum-safety 0)) (type (unsigned-byte 16) high low) (type octet-vector buf) (type (simple-array (unsigned-byte 16) (*)) table) (fixnum end)) (let ((len end)) (declare (fixnum len)) (dotimes (n len (values high low)) (declare (fixnum n)) (let ((index (logxor (logand low #xFF) (aref buf n)))) (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)) (setf low (logxor (ash (logand high #xFF) 8) (ash low -8) t-low)) (setf high (logxor (ash high -8) t-high))))))))) (defun crc32-sequence (sequence &key (end (length sequence))) "Return an octet sequence of four bytes containing the crc32 checksum of SEQUENCE." (multiple-value-bind (high low) (crc32 #xFFFF #xFFFF sequence end) (setf high (logxor #xFFFF high) low (logxor #xFFFF low)) (make-array 4 :element-type 'octet :initial-contents (list (ldb (byte 8 8) high) (ldb (byte 8 0) high) (ldb (byte 8 8) low) (ldb (byte 8 0) low))))) cl-salza-0.7.4/deflate-stream.lisp000066400000000000000000000150241076012157700170260ustar00rootroot00000000000000;;; ;;; deflate-stream.lisp ;;; ;;; Created: 2005-03-12 by Zach Beane ;;; ;;; An interface to the DEFLATE data compression format. See the ;;; "packages.lisp" file for the public interface. ;;; ;;; Copyright (c) 2005 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. ;;; ;;; $Id: deflate-stream.lisp,v 1.12 2005/04/28 18:45:26 xach Exp $ (in-package :salza-deflate) (declaim (inline deflate-stream-buffer)) (declaim (inline deflate-stream-pos)) (declaim (inline deflate-stream-byte)) (declaim (inline deflate-stream-end)) (declaim (inline deflate-stream-bits-left)) (define-condition deflate-stream-buffer-full () ((deflate-stream :initarg :deflate-stream :reader deflate-stream-buffer-full-deflate-stream))) (defvar *compressor-buffer-size* 65536) (defstruct (deflate-stream (:constructor %make-deflate-stream (buffer pos end callback))) (buffer nil :type (or octet-vector null)) (callback nil :type (or function null)) (pos 0 :type buffer-offset) (end 0 :type buffer-offset) (byte 0 :type octet) (bits-left 8 :type octet) (compress-buffer (make-array *compressor-buffer-size* :element-type 'octet) :type (simple-array octet)) (compress-pos 0 :type buffer-offset) (compress-positions (make-fixhash-table))) (defun default-callback (deflate-stream) (cerror "Resume output" 'deflate-stream-buffer-full :deflate-stream deflate-stream)) (defun make-deflate-stream (buffer &key (pos 0) end (callback #'default-callback)) (check-type buffer octet-vector) (setf end (or end (length buffer))) (%make-deflate-stream buffer pos end callback)) (defmethod print-object ((object deflate-stream) stream) (print-unreadable-object (object stream :type t :identity t) (format stream "~D/~D ~D ~D/8" (deflate-stream-pos object) (deflate-stream-end object) (deflate-stream-byte object) (deflate-stream-bits-left object)))) (defun write-bits (code length deflate-stream) "Save LENGTH low bits of CODE to the buffer of DEFLATE-STREAM. If the end of the deflate-stream buffer is reached, raise a continuable error of type DEFLATE-STREAM-BUFFER-FULL." (declare (type (unsigned-byte 24) code) (type (integer 0 24) length) (type deflate-stream deflate-stream) (optimize (speed 3) (safety 0) (debug 0))) (let ((byte (deflate-stream-byte deflate-stream)) (bits-left (deflate-stream-bits-left deflate-stream)) (pos (deflate-stream-pos deflate-stream)) (buffer (deflate-stream-buffer deflate-stream)) (end (deflate-stream-end deflate-stream))) (declare (type octet-vector buffer) (type (integer 0 8) bits-left) (type (integer 0 255) byte) (type buffer-offset pos end)) (flet ((output-byte () (setf (aref buffer pos) byte) (incf pos) (loop (when (< pos end) (return)) (setf (deflate-stream-pos deflate-stream) pos) (funcall (the function (deflate-stream-callback deflate-stream)) deflate-stream) (setf buffer (deflate-stream-buffer deflate-stream) pos (deflate-stream-pos deflate-stream))))) (declare (inline output-byte)) (tagbody loop (cond ((> length bits-left) (setf byte (logior byte (logand #xFF (ash code (- 8 bits-left))))) (output-byte) (decf length bits-left) (setf code (ash code (- bits-left))) (setf bits-left 8 byte 0) (go loop)) ((= length bits-left) (setf byte (logior byte (logand #xFF (ash code (- 8 bits-left))))) (output-byte) (setf bits-left 8 byte 0)) (t (setf byte (logior byte (logand #xFF (ash code (- 8 bits-left))))) (decf bits-left length)))) (setf (deflate-stream-bits-left deflate-stream) bits-left (deflate-stream-byte deflate-stream) byte (deflate-stream-pos deflate-stream) pos)))) (defconstant +deflate-fixed-tables-code+ #b01) (defun write-block-header (deflate-stream) ;; The block header ;; BFINAL is always set, since right now dynamic codes are not ;; supported so we never need to start a new block (write-bits 1 1 deflate-stream) (write-bits +deflate-fixed-tables-code+ 2 deflate-stream)) (defun flush-deflate-stream (deflate-stream) "If there is a pending unwritten byte in the deflate-stream, save it and advance the stream position." (when (< (deflate-stream-bits-left deflate-stream) 8) (setf (aref (deflate-stream-buffer deflate-stream) (deflate-stream-pos deflate-stream)) (deflate-stream-byte deflate-stream)) (setf (deflate-stream-byte deflate-stream) 0 (deflate-stream-bits-left deflate-stream) 8) (incf (deflate-stream-pos deflate-stream)) (loop (when (< (deflate-stream-pos deflate-stream) (deflate-stream-end deflate-stream)) (return)) (funcall (deflate-stream-callback deflate-stream) deflate-stream)))) cl-salza-0.7.4/examples/000077500000000000000000000000001076012157700150545ustar00rootroot00000000000000cl-salza-0.7.4/examples/gzip.lisp000066400000000000000000000056301076012157700167220ustar00rootroot00000000000000;;; ;;; gzip.lisp ;;; ;;; Created: 2005-03-14 by Zach Beane ;;; ;;; An example use of the salza DEFLATE interface functions. ;;; ;;; ;;; $Id: gzip.lisp,v 1.4 2005/03/18 21:45:40 xach Exp $ (defpackage :gzip (:use :cl :salza-deflate) (:export :gzip)) (in-package :gzip) (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +gzip-signature+ (if (boundp '+gzip-signature+) (symbol-value '+gzip-signature+) #(#x1F #x8B)))) (defconstant +gzip-deflate-compression+ 8) (defconstant +gzip-flags+ 0) (defconstant +gzip-fast-compression+ 4) (defconstant +gzip-unix-os+ 3) (defun write-gzip-header (stream) (write-sequence +gzip-signature+ stream) (write-byte +gzip-deflate-compression+ stream) (write-byte +gzip-flags+ stream) ;; mtime (write-sequence #(0 0 0 0) stream) (write-byte +gzip-fast-compression+ stream) (write-byte +gzip-unix-os+ stream)) (defun write-gzip-data (input output) (let* ((input-buffer (make-array 8192 :element-type '(unsigned-byte 8))) (compress-buffer (make-array 8192 :element-type '(unsigned-byte 8))) (callback (lambda (deflate-stream) (write-sequence compress-buffer output :end (deflate-stream-pos deflate-stream)) (setf (deflate-stream-pos deflate-stream) 0))) (deflate-stream (make-deflate-stream compress-buffer :callback callback)) (crc-high #xFFFF) (crc-low #xFFFF) (size 0)) (flet ((write-uint32 (value) (write-byte (ldb (byte 8 0) value) output) (write-byte (ldb (byte 8 8) value) output) (write-byte (ldb (byte 8 16) value) output) (write-byte (ldb (byte 8 24) value) output))) (start-deflate-stream deflate-stream) (loop (let ((end (read-sequence input-buffer input))) (incf size end) (deflate-write-sequence input-buffer deflate-stream :end end) (unless (zerop end) (multiple-value-setq (crc-high crc-low) (crc32 crc-high crc-low input-buffer end))) (when (zerop end) (finish-deflate-stream deflate-stream) (setf crc-high (logxor crc-high #xFFFF) crc-low (logxor crc-low #xFFFF)) (write-uint32 (logior (ash crc-high 16) crc-low)) (write-uint32 size) (return))))))) (defun gzip (input-file output-file) (with-open-file (input input-file :direction :input :element-type '(unsigned-byte 8)) (with-open-file (output output-file :direction :output :if-exists :supersede :element-type '(unsigned-byte 8)) (write-gzip-header output) (write-gzip-data input output) (truename output))))cl-salza-0.7.4/examples/png.lisp000066400000000000000000000125311076012157700165330ustar00rootroot00000000000000;;; ;;; png.lisp ;;; ;;; Created: 2005-03-14 by Zach Beane ;;; ;;; An example use of the salza ZLIB interface functions. ;;; ;;; (setq png (make-instance 'png ;;; :color-type :truecolor ;;; :height 10 ;;; :width 10 ;;; :image-data <300 bytes of image data>)) ;;; ;;; (write-png png "example.png") ;;; ;;; ;;; $Id: png.lisp,v 1.5 2007/03/07 16:08:33 xach Exp $ (defpackage :png (:use :cl :salza :salza-deflate) (:export :png :write-png)) (in-package :png) ;;; Chunks (defclass chunk () ((buffer :initarg :buffer :reader buffer) (pos :initform 4 :accessor pos))) (defun chunk-write-byte (byte chunk) "Save one byte to CHUNK." (setf (aref (buffer chunk) (pos chunk)) byte) (incf (pos chunk))) (defun chunk-write-uint32 (integer chunk) "Save INTEGER to CHUNK as four bytes." (dotimes (i 4) (setf (aref (buffer chunk) (pos chunk)) (logand #xFF (ash integer (+ -24 (* i 8))))) (incf (pos chunk)))) (defun make-chunk (a b c d size) "Make a chunk that uses A, B, C, and D as the signature bytes, with data size SIZE." (let ((buffer (make-array (+ size 4) :element-type '(unsigned-byte 8)))) (setf (aref buffer 0) a (aref buffer 1) b (aref buffer 2) c (aref buffer 3) d) (make-instance 'chunk :buffer buffer))) (defun write-uint32 (integer stream) (dotimes (i 4) (write-byte (logand #xFF (ash integer (+ -24 (* i 8)))) stream))) (defun write-chunk (chunk stream) (write-uint32 (- (pos chunk) 4) stream) (write-sequence (buffer chunk) stream :end (pos chunk)) (write-sequence (crc32-sequence (buffer chunk) :end (pos chunk)) stream)) ;;; PNGs (defclass png () ((width :initarg :width :reader width) (height :initarg :height :reader height) (color-type :initform :truecolor :initarg :color-type :reader color-type) (bpp :initform 8 :initarg :bpp :reader bpp) (image-data :initarg :image-data :reader image-data))) (defmethod initialize-instance :after ((png png) &rest args) (declare (ignore args)) (assert (= (length (image-data png)) (* (height png) (rowstride png))))) (defgeneric write-png (png pathname &key if-exists)) (defgeneric write-ihdr (png stream)) (defgeneric ihdr-color-type (png)) (defgeneric write-idat (png stream)) (defgeneric write-iend (png stream)) (defgeneric write-png-header (png stream)) (defgeneric scanline-offset (png scanline)) (defgeneric rowstride (png)) (defgeneric samples/pixel (png)) (defmethod samples/pixel (png) (ecase (color-type png) (:grayscale 1) (:truecolor 3) (:indexed-color 1) (:grayscale-alpha 2) (:truecolor-alpha 4))) (defmethod rowstride (png) (* (width png) (samples/pixel png))) (defmethod scanline-offset (png scanline) (* scanline (rowstride png))) (defmethod write-png-header (png stream) (let ((header (make-array 8 :element-type '(unsigned-byte 8) :initial-contents '(137 80 78 71 13 10 26 10)))) (write-sequence header stream))) (defvar *color-types* '((:grayscale . 0) (:truecolor . 2) (:indexed-color . 3) (:grayscale-alpha . 4) (:truecolor-alpha . 6))) (defmethod ihdr-color-type (png) (cdr (assoc (color-type png) *color-types*))) (defmethod write-ihdr (png stream) (let ((chunk (make-chunk 73 72 68 82 13))) (chunk-write-uint32 (width png) chunk) (chunk-write-uint32 (height png) chunk) (chunk-write-byte (bpp png) chunk) (chunk-write-byte (ihdr-color-type png) chunk) ;; compression method (chunk-write-byte 0 chunk) ;; filtering (chunk-write-byte 0 chunk) ;; interlace (chunk-write-byte 0 chunk) (write-chunk chunk stream))) (defmethod write-idat (png stream) (let* ((chunk (make-chunk 73 68 65 84 16384)) (filter-type (make-array 1 :element-type '(unsigned-byte 8) :initial-element 0))) (flet ((write-full-chunk (zlib-stream) (setf (pos chunk) (zlib-stream-position zlib-stream)) (write-chunk chunk stream) (fill (buffer chunk) 0 :start 4) (setf (zlib-stream-position zlib-stream) 4))) (let ((zlib-stream (make-zlib-stream (buffer chunk) :start 4 :callback #'write-full-chunk))) (dotimes (i (height png)) (let* ((start-offset (scanline-offset png i)) (end-offset (+ start-offset (rowstride png)))) (zlib-write-sequence filter-type zlib-stream) (zlib-write-sequence (image-data png) zlib-stream :start start-offset :end end-offset))) (finish-zlib-stream zlib-stream))))) (defmethod write-iend (png stream) (let ((chunk (make-chunk 73 69 78 68 0))) (write-chunk chunk stream))) (defmethod write-png (png file &key (if-exists :supersede)) (with-open-file (stream file :direction :output :if-exists if-exists :if-does-not-exist :create :element-type '(unsigned-byte 8)) (write-png-header png stream) (write-ihdr png stream) (write-idat png stream) (write-iend png stream) (truename file))) cl-salza-0.7.4/fixhash.lisp000066400000000000000000000132641076012157700155670ustar00rootroot00000000000000;;; ;;; fixhash.lisp ;;; ;;; Created: 2005-03-19 by Zach Beane ;;; ;;; A hashtable whose keys and values are known to be fixnums^Wof a ;;; fixed, relatively small size. Sadly, not small enough to be ;;; fixnums on LispWorks. ;;; ;;; This table isn't general; it assumes that the compressor never ;;; uses zero for a key. ;;; ;;; Copyright (c) 2005 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. ;;; ;;; $Id: fixhash.lisp,v 1.7 2005/04/01 21:55:24 xach Exp $ (defpackage :fixhash (:use :cl) (:export :make-fixhash-table :getfixhash :clrfixhash)) (in-package :fixhash) (deftype fixhash-integer () "#xFFFFFF is out of fixnum range on LispWorks." '(integer 0 #xFFFFFF)) (defparameter *sizes* #(4096 16384 65536 131072)) (defstruct fixhash-table (level 0 :type fixnum) (size 4096 :type fixnum) (keys/values (make-array (* 4096 2) :element-type 'fixhash-integer :initial-element 0) :type (simple-array fixhash-integer (*))) (last-key 0 :type fixhash-integer) (last-key-pos 0 :type fixnum)) (defmethod print-object ((fixhash-table fixhash-table) stream) (print-unreadable-object (fixhash-table stream :type t :identity t) (format stream "~D/~D" (fixhash-table-level fixhash-table) (fixhash-table-size fixhash-table)))) (defun rehash (table) (declare (optimize (speed 3) (safety 0))) (let ((level (fixhash-table-level table)) (keys/values (fixhash-table-keys/values table)) (size (fixhash-table-size table))) (when (= 3 level) (error "Hash table full")) (let* ((new-size (svref *sizes* (incf level))) (new-keys/values (make-array (the fixnum (* new-size 2)) :initial-element 0 :element-type 'fixhash-integer))) (dotimes (i (* size 2)) (setf (aref new-keys/values i) (aref keys/values i))) (setf (fixhash-table-keys/values table) new-keys/values (fixhash-table-size table) new-size (fixhash-table-level table) level)))) (defun getfixhash (k fixhash-table) (declare (optimize (speed 3) (safety 0) (debug 0) #+lispworks (hcl:fixnum-safety 0)) (type fixhash-integer k)) (let* ((size (fixhash-table-size fixhash-table)) (mask (1- size)) (h1 (logand k mask)) (h2 (logior 1 (mod k (1- size)))) (j 0) (i*h2 0) (table (fixhash-table-keys/values fixhash-table))) (declare (type (integer 0 131072) size mask h1 h2 j i*h2)) (dotimes (i size (and (rehash fixhash-table) 0)) (declare (fixnum i)) (incf i*h2 h2) (setf j (ash (logand mask (+ h1 i*h2)) 1)) (let ((kt (aref table j))) (when (= k kt) (return (aref table (1+ j)))) (when (zerop kt) (setf (fixhash-table-last-key fixhash-table) k (fixhash-table-last-key-pos fixhash-table) j) (return 0)))))) (defun (setf getfixhash) (new-value k fixhash-table) (declare (optimize (speed 3) (safety 0) (debug 0) #+lispworks (hcl:fixnum-safety 0)) (type fixhash-integer new-value k)) (let ((last-key (fixhash-table-last-key fixhash-table)) (last-key-pos (fixhash-table-last-key-pos fixhash-table)) (table (fixhash-table-keys/values fixhash-table))) (if (= last-key k) (setf (aref table last-key-pos) k (aref table (1+ last-key-pos)) new-value) (let* ((size (fixhash-table-size fixhash-table)) (mask (1- size)) (h1 (logand k mask)) (h2 (logior 1 (mod k (1- size)))) (i*h2 0) (j 0)) (declare (type (integer 0 131072) h2 h1 i*h2 size mask)) (dotimes (i size) (declare (fixnum i)) (incf i*h2 h2) (setf j (ash (logand mask (+ h1 i*h2)) 1)) (let ((kt (aref table j))) (when (or (= k kt) (zerop kt)) (setf (aref table j) k (aref table (1+ j)) new-value) (return new-value)))))))) (defun clrfixhash (fixhash-table) (declare (optimize (speed 3) (safety 0) #+lispworks (hcl:fixnum-safety 0))) (let ((table (fixhash-table-keys/values fixhash-table))) (dotimes (i (length table)) (declare (fixnum i)) (setf (aref table i) 0))) fixhash-table) cl-salza-0.7.4/huffman.lisp000066400000000000000000000137471076012157700155670ustar00rootroot00000000000000;;; ;;; huffman.lisp ;;; ;;; Created: 2005-03-12 by Zach Beane ;;; ;;; Copyright (c) 2005 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. ;;; ;;; $Id: huffman.lisp,v 1.5 2005/03/20 21:33:49 xach Exp $ (in-package :salza-deflate) ;;; ;;; Huffman codes are written out to the stream backwards, so we save ;;; them backwards too. ;;; (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-table () "Generate the fixed Huffman code table specified by RFC1951." (let ((table (make-array (* 288 2))) (i 0)) (flet ((fill-range (length start end) (loop for j from start to end do (setf (aref table i) (reverse-bits j length) (aref table (incf i)) length) (incf i)))) (fill-range 8 #b00110000 #b10111111) (fill-range 9 #b110010000 #b111111111) (fill-range 7 #b0000000 #b0010111) (fill-range 8 #b11000000 #b11000111) table))) ;;; DEFLATE uses special Huffman codes to indicate that there is extra ;;; literal data after the code. The WRITE-LITERAL, WRITE-LENGTH, and ;;; WRITE-DISTANCE functions close over vectors that contain bit ;;; patterns at the even offsets and bit lengths at the odd offsets. ;;; ;;; Since we only deal with encoding with the fixed Huffman table ;;; described in the RFC right now, everything can be precomputed. (defun save-pair (array i code length) "Store CODE and LENGTH in consecutive positions in ARRAY." (let ((index (ash i 1))) (setf (aref array index) code (aref array (1+ index)) length))) (defun length-table (huffman-table) "Compute a table of the (Huffman + extra bits) values for all possible lengths for the given HUFFMAN-TABLE." (let ((table (make-array (* 259 2))) (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))) (flet ((save-value (extra-bit-count extra-value) (let ((huffman-value (aref huffman-table (ash code 1))) (huffman-count (aref huffman-table (1+ (ash code 1))))) (save-pair table 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)) table)) (defun distance-table () "Compute a table of the (code + extra bits) values for all possible distances as specified by RFC1951." (let ((table (make-array (* 32769 2))) (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) (save-pair table distance (logior (ash extra-value 5) (reverse-bits code 5)) (+ 5 extra-bit-count)))) (dolist (count extra-bit-counts table) (dotimes (i (expt 2 count)) (save-value count i) (incf distance)) (incf code))))) (let ((lvtable (fixed-huffman-table))) (declare (type simple-vector lvtable)) (defun write-literal (code bitstream) "Write the Huffman code for the literal CODE to BITSTREAM." (declare (optimize (speed 3) (safety 0)) (type (integer 0 258) code)) (write-bits (svref lvtable (ash code 1)) (svref lvtable (1+ (ash code 1))) bitstream))) (let ((lvtable (distance-table))) (declare (type simple-vector lvtable)) (defun write-distance (distance bitstream) "Write the Huffman code and extra bits for distance DISTANCE to bitstream." (declare (optimize (speed 3) (safety 0)) (type (integer 0 32768) distance)) (write-bits (svref lvtable (ash distance 1)) (svref lvtable (1+ (ash distance 1))) bitstream))) (let ((lvtable (length-table (fixed-huffman-table)))) (declare (type simple-vector lvtable)) (defun write-length (length bitstream) "Write the 5 bit code and extra bits for the length LENGTH to BITSTREAM." (declare (optimize (speed 3) (safety 0)) (type (integer 0 258) length)) (write-bits (svref lvtable (ash length 1)) (svref lvtable (1+ (ash length 1))) bitstream))) cl-salza-0.7.4/octet-replace.lisp000066400000000000000000000041471076012157700166640ustar00rootroot00000000000000;;; ;;; octet-replace.lisp ;;; ;;; Created: 2005-03-18 by Zach Beane ;;; ;;; REPLACE is generally pretty slow. Since we are working with octet ;;; vectors, provide a different version that is faster. ;;; ;;; Copyright (c) 2005 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. ;;; ;;; $Id: octet-replace.lisp,v 1.2 2005/03/23 20:14:19 xach Exp $ (in-package :salza-deflate) (defun octet-replace (sequence1 sequence2 start1 end1 start2 end2) (declare (type octet-vector sequence1 sequence2) (fixnum start1 end1 start2 end2) (optimize (speed 3) (safety 0))) (let ((i (min (- end1 start1) (- end2 start2)))) (declare (fixnum i)) (loop (when (zerop i) (return-from octet-replace sequence1)) (setf (aref sequence1 start1) (aref sequence2 start2)) (incf start1) (incf start2) (decf i))))cl-salza-0.7.4/packages.lisp000066400000000000000000000051041076012157700157050ustar00rootroot00000000000000;;; ;;; packages.lisp ;;; ;;; Created: 2005-03-12 by Zach Beane ;;; ;;; Copyright (c) 2005 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. ;;; ;;; $Id: packages.lisp,v 1.9 2005/03/25 21:09:02 xach Exp $ (in-package :cl) (defpackage :salza-types (:use :cl) (:export :octet :octet-vector :buffer-offset)) (defpackage :salza-deflate (:use :cl :salza-types :fixhash) (:nicknames :deflate) (:export :make-deflate-stream :deflate-stream-buffer :deflate-stream-pos :deflate-stream-callback :start-deflate-stream :deflate-write-byte :deflate-write-sequence :deflate-write-string :finish-deflate-stream :deflate-stream-buffer-full :deflate-stream-buffer-full-deflate-stream :crc32 :crc32-sequence)) (defpackage :salza (:use :cl :salza-types :salza-deflate) (:nicknames :zlib) (:export :make-zlib-stream :zlib-write-sequence :zlib-write-string :zlib-stream-buffer :zlib-stream-position :zlib-stream-callback :finish-zlib-stream :compress-sequence :compress-string :compess-stream :zlib-buffer-full :zlib-buffer-full-zlib-stream)) cl-salza-0.7.4/salza.asd000066400000000000000000000055421076012157700150470ustar00rootroot00000000000000;;; ;;; zlib.asd ;;; ;;; Created: 2005-03-12 by Zach Beane ;;; ;;; Copyright (c) 2005 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. ;;; ;;; $Id: salza.asd,v 1.4 2005/03/20 04:54:55 xach Exp $ (defpackage :salza-system (:use :cl :asdf)) (in-package :salza-system) (defsystem :salza :components ((:file "fixhash") (:file "packages" :depends-on ("fixhash")) (:file "types" :depends-on ("packages")) (:file "deflate-stream" :depends-on ("packages" "types")) (:file "huffman" :depends-on ("packages" "types" "deflate-stream")) (:file "octet-replace" :depends-on ("packages")) (:file "compressor" :depends-on ("packages" "types" "deflate-stream" "huffman" "octet-replace")) (:file "deflate-stream-interface" :depends-on ("packages" "compressor" "deflate-stream")) (:file "zlib" :depends-on ("packages" "types" "deflate-stream" "huffman" "compressor")))) cl-salza-0.7.4/types.lisp000066400000000000000000000032371076012157700153000ustar00rootroot00000000000000;;; ;;; types.lisp ;;; ;;; Created: 2005-03-12 by Zach Beane ;;; ;;; Copyright (c) 2005 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. ;;; ;;; $Id: types.lisp,v 1.4 2005/04/01 22:09:58 xach Exp $ (in-package :salza-types) (deftype octet () '(unsigned-byte 8)) (deftype buffer-offset () '(integer 0 #.(1- array-dimension-limit))) (deftype octet-vector () '(simple-array octet (*))) cl-salza-0.7.4/zlib.lisp000066400000000000000000000236161076012157700150770ustar00rootroot00000000000000;;; ;;; zlib.lisp ;;; ;;; Created: 2005-03-12 by Zach Beane ;;; ;;; zlib encapsulation of a deflate output stream. ;;; ;;; Copyright (c) 2005 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. ;;; ;;; $Id: zlib.lisp,v 1.16 2007/03/06 19:07:37 xach Exp $ (in-package :salza) ;;; Adler checksum (defconstant +adler32-base+ 65521) (defun adler32 (adler-high adler-low buf start end) (declare (optimize (speed 3) (safety 0) (debug 0) #+lispworks (hcl:fixnum-safety 0)) (type buffer-offset start end) (type fixnum adler-high adler-low) (type octet-vector buf)) (cond ((> start end) (error "Invalid start and end values (start must be <= end)")) ((= start end) (values adler-high adler-low)) (t (let ((length (- end start)) (i 0) (k 0) (s1 adler-low) (s2 adler-high)) (declare (type buffer-offset i k length) (type fixnum s1 s2)) (tagbody loop (setf k (min 16 length)) (decf length k) sum (setf s1 (+ (aref buf (+ 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))))) ;;; Conditions (define-condition zlib-buffer-full () ((zlib-stream :initarg :zlib-stream :reader zlib-buffer-full-zlib-stream)) (:documentation "When no callback is provided in MAKE-ZLIB-STREAM, this condition is signalled in a continuable error when the buffer backing the zlib-stream has reached the end. It is also called at the end of output in FINISH-ZLIB-STREAM. User code should handle this condition, do something appropriate with the buffer, and reset the zlib-stream position.")) (defstruct (zlib-stream (:constructor %make-zlib-stream (deflate-stream callback))) deflate-stream callback (adler-high 0 :type (unsigned-byte 16)) (adler-low 1 :type (unsigned-byte 16))) (defun zlib-stream-position (zlib-stream) (deflate-stream-pos (zlib-stream-deflate-stream zlib-stream))) (defun (setf zlib-stream-position) (new-value zlib-stream) (setf (deflate-stream-pos (zlib-stream-deflate-stream zlib-stream)) new-value)) (defun zlib-stream-buffer (zlib-stream) (deflate-stream-buffer (zlib-stream-deflate-stream zlib-stream))) (defmethod print-object ((object zlib-stream) stream) (print-unreadable-object (object stream :type t :identity t) (format stream "~D" (zlib-stream-position object)))) (defconstant +zlib-compression-method+ 8 "The DEFLATE method code, sent as the high nybble of the first byte of the stream.") (defconstant +zlib-compression-info+ 0 "From the spec: For CM = 8, CINFO is the base-2 logarithm of the LZ77 window size, minus eight (CINFO=7 indicates a 32K window size).") (defconstant +zlib-compression-level+ 2 "The default compression level code.") (defconstant +zlib-preset-dictionary-flag+ 0 "No preset dictionary.") (defun write-zlib-stream-header (deflate-stream) (let* ((cm+flags (logior (ash +zlib-compression-info+ 12) (ash +zlib-compression-method+ 8) (ash +zlib-compression-level+ 6))) (check (logandc2 31 (mod cm+flags 31)))) (setf cm+flags (logior cm+flags check)) (deflate-write-byte (ash cm+flags -8) deflate-stream) (deflate-write-byte cm+flags deflate-stream))) (defun default-callback (zlib-stream) (cerror "Retry write" 'zlib-buffer-full :zlib-stream zlib-stream)) (defun make-zlib-stream (buffer &key (start 0) end callback) "Create and return a zlib-stream. START is the first offset in BUFFER to which compressed data is written. END is the offset after the last writable byte in BUFFER (if not provided, the length of BUFFER is used). CALLBACK is a function to be called when BUFFER is full and when the zlib-stream is finished. If no callback is provided, a function that raises a continuable ZLIB-BUFFER-FULL error is used." (check-type buffer (simple-array octet)) (setf end (or end (length buffer))) ;; XXX This seems a little silly, but it captures the binding of ;; zlib-stream in the lambda (let* ((zlib-stream nil) (zlib-callback (or callback #'default-callback)) (deflate-callback (lambda (deflate-stream) (declare (ignore deflate-stream)) (funcall zlib-callback zlib-stream))) (deflate-stream (make-deflate-stream buffer :pos start :end end :callback deflate-callback))) (setf zlib-stream (%make-zlib-stream deflate-stream callback)) (write-zlib-stream-header deflate-stream) (start-deflate-stream deflate-stream) zlib-stream)) (defun zlib-write-sequence (sequence zlib-stream &key (start 0) (end (length sequence))) "Compress SEQUENCE and write them to ZLIB-STREAM." (multiple-value-bind (adler-high adler-low) (adler32 (zlib-stream-adler-high zlib-stream) (zlib-stream-adler-low zlib-stream) sequence start end) (setf (zlib-stream-adler-high zlib-stream) adler-high (zlib-stream-adler-low zlib-stream) adler-low) (deflate-write-sequence sequence (zlib-stream-deflate-stream zlib-stream) :start start :end end))) (defun zlib-write-string (string zlib-stream) "Write the octet representation of STRING to ZLIB-STREAM." (zlib-write-sequence (deflate::string-to-octets string 0 (length string)) zlib-stream)) (defun finish-zlib-stream (zlib-stream) "Conclude output to the zlib-stream, writing the terminating code for the block to the buffer and and appending the four adler32 checksum bytes. Call ZLIB-STREAM's callback as the final step." (let ((deflate-stream (zlib-stream-deflate-stream zlib-stream))) (finish-deflate-stream deflate-stream) (let ((high (zlib-stream-adler-high zlib-stream)) (low (zlib-stream-adler-low zlib-stream))) (deflate-write-byte (ldb (byte 8 8) high) deflate-stream) (deflate-write-byte (ldb (byte 8 0) high) deflate-stream) (deflate-write-byte (ldb (byte 8 8) low) deflate-stream) (deflate-write-byte (ldb (byte 8 0) low) deflate-stream) (funcall (zlib-stream-callback zlib-stream) zlib-stream)))) ;;; Convenience functions (defun compress-sequence (input) "Return an octet sequence containing the bytes of INPUT compressed to the zlib format." (check-type input octet-vector) (let* ((buffer-size 8192) (zlib-buffer (make-array buffer-size :element-type 'octet)) (offset 0) (output (make-array buffer-size :adjustable t :initial-element 0))) (flet ((zlib-callback (zlib-stream) (let ((pos (zlib-stream-position zlib-stream))) (adjust-array output (+ offset pos)) (replace output (zlib-stream-buffer zlib-stream) :start1 offset :end2 pos) (incf offset pos) (setf (zlib-stream-position zlib-stream) 0)))) (let ((zlib-stream (make-zlib-stream zlib-buffer :callback #'zlib-callback))) (zlib-write-sequence input zlib-stream) (finish-zlib-stream zlib-stream) output)))) (defun compress-string (string) "Return the zlib compressed sequence of STRING's octet sequence representation." (compress-sequence (deflate::string-to-octets string 0 (length string)))) (defun compress-stream (input output) "Read input from the stream INPUT and write it in ZLIB format to the stream OUTPUT. Both streams must have element-types of '(unsigned-byte 8)." (flet ((flush-stream (zlib-stream) (write-sequence (zlib-stream-buffer zlib-stream) output :end (zlib-stream-position zlib-stream)) (setf (zlib-stream-position zlib-stream) 0))) (let* ((input-buffer (make-array 8192 :element-type 'octet)) (output-buffer (make-array 8192 :element-type 'octet)) (zlib-stream (make-zlib-stream output-buffer :callback #'flush-stream))) (loop (let ((end (read-sequence input-buffer input))) (zlib-write-sequence input-buffer zlib-stream :end end) (when (zerop end) (finish-zlib-stream zlib-stream) (return)))))))