Initial import.
Wed Sep 3 13:24:16 PDT 2008 mail@chaitanyagupta.com
* Initial import.
diff -rN -u old-cl-bzip2/bzip2.lisp new-cl-bzip2/bzip2.lisp
--- old-cl-bzip2/bzip2.lisp 1969-12-31 16:00:00.000000000 -0800
+++ new-cl-bzip2/bzip2.lisp 2014-07-29 03:48:27.000000000 -0700
@@ -0,0 +1,434 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; bzip2.lisp
+
+;;; Copyright (c) 2008, Chaitanya Gupta.
+;;; All rights reserved.
+;;;
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;; 1. Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+;;; 2. 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.
+;;; 3. The name of the author may not be used to endorse or promote products
+;;; derived from this software without specific prior written permission.
+;;;
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS 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 #:cl-bzip2
+ (:use #:cl #:cffi)
+ (:nicknames #:bzip2)
+ (:export "COMPRESS"
+ "DECOMPRESS"
+ "BZ-ERROR"))
+
+(in-package #:cl-bzip2)
+
+;;; Define and load libbzip2
+
+(define-foreign-library libbz2
+ (:darwin "libbz2.dylib")
+ (:unix "libbz2.so")
+ (t (:default "libbz2")))
+
+(with-simple-restart (skip "Skip loading foreign library LIBBZIP2.")
+ (use-foreign-library libbz2))
+
+;;; bz return codes
+
+(defvar *bz-return-codes* (make-hash-table))
+
+(defmacro define-bz-return-code (name code)
+ (let ((var-name (format nil "+~A+" (substitute #\- #\_ (string name)))))
+ `(progn
+ (setf (gethash ,code *bz-return-codes*) ',name)
+ (defconstant ,(intern var-name :bzip2) ,code))))
+
+(define-bz-return-code BZ_OK 0)
+(define-bz-return-code BZ_RUN_OK 1)
+(define-bz-return-code BZ_FLUSH_OK 2)
+(define-bz-return-code BZ_FINISH_OK 3)
+(define-bz-return-code BZ_STREAM_END 4)
+(define-bz-return-code BZ_SEQUENCE_ERROR -1)
+(define-bz-return-code BZ_PARAM_ERROR -2)
+(define-bz-return-code BZ_MEM_ERROR -3)
+(define-bz-return-code BZ_DATA_ERROR -4)
+(define-bz-return-code BZ_DATA_ERROR_MAGIC -5)
+(define-bz-return-code BZ_IO_ERROR -6)
+(define-bz-return-code BZ_UNEXPECTED_EOF -7)
+(define-bz-return-code BZ_OUTBUFF_FULL -8)
+(define-bz-return-code BZ_CONFIG_ERROR -9)
+
+;;; bz_stream
+
+(defcstruct bz-stream
+ (next-in :pointer)
+ (avail-in :uint)
+ (total-in-lo32 :uint)
+ (total-in-hi32 :uint)
+
+ (next-out :pointer)
+ (avail-out :uint)
+ (total-out-lo32 :uint)
+ (total-out-hi32 :uint)
+
+ (state :pointer)
+
+ (bzalloc :pointer)
+ (bzfree :pointer)
+ (opaque :pointer))
+
+(defun bz-stream-slot-value (object slot-name)
+ (foreign-slot-value object 'bz-stream slot-name))
+
+(defun (setf bz-stream-slot-value) (value object slot-name)
+ (setf (foreign-slot-value object 'bz-stream slot-name) value))
+
+(defun make-bz-stream ()
+ (let ((bz-stream (foreign-alloc 'bz-stream)))
+ (setf (bz-stream-slot-value bz-stream 'bzalloc) (null-pointer)
+ (bz-stream-slot-value bz-stream 'bzfree) (null-pointer)
+ (bz-stream-slot-value bz-stream 'opaque) (null-pointer))
+ bz-stream))
+
+(defun free-bz-stream (bz-stream)
+ (foreign-free bz-stream))
+
+(defmacro with-bz-stream ((var) &body body)
+ `(let ((,var (make-bz-stream)))
+ (unwind-protect (progn ,@body)
+ (free-bz-stream ,var))))
+
+;;; Error handling
+
+(define-condition bz-error (error)
+ ((code :initarg :code
+ :reader bz-error-code
+ :initform (error "CODE is required."))
+ (cfun :initarg :cfun
+ :reader bz-error-cfun
+ :initform (error "CFUN is required.")))
+ (:report (lambda (c stream)
+ (format stream "Error in function ~A: ~A (~A)"
+ (bz-error-cfun c)
+ (gethash (bz-error-code c) *bz-return-codes*)
+ (bz-error-code c))))
+ (:documentation "The default condition type for any BZIP2
+ compression/decompression related errors."))
+
+(defun bz-error (code cfun)
+ (error 'bz-error
+ :code code
+ :cfun cfun))
+
+(defun ensure-list (item)
+ (etypecase item
+ (atom (list item))
+ (list item)))
+
+(defmacro with-bz-error-handling ((cfun &key accept deny) &body body)
+ (assert (not (and accept deny))
+ ()
+ "ACCEPT and DENY cannot both be non-NIL.")
+ (let ((return-code (gensym "RET-CODE")))
+ `(let ((,return-code (progn
+ ,@body)))
+ ,(cond
+ (accept `(unless (member ,return-code (ensure-list ,accept))
+ (bz-error ,return-code ,cfun)))
+ (deny `(when (member ,return-code (ensure-list ,deny))
+ (bz-error ,return-code ,cfun))))
+ ,return-code)))
+
+;;; Wrappers over low-level compress API
+
+(defcfun ("BZ2_bzCompressInit" %bz-compress-init) :int
+ (bz-stream :pointer)
+ (block-size-100k :int)
+ (verbosity :int)
+ (work-factor :int))
+
+(defun bz-compress-init (bz-stream block-size-100k verbosity work-factor)
+ (with-bz-error-handling ("BZ2_bzCompressInit" :accept +bz-ok+)
+ (%bz-compress-init bz-stream block-size-100k verbosity work-factor)))
+
+;;;; Actions for BZ2_bzCompress
+
+(defconstant +bz-run+ 0)
+(defconstant +bz-flush+ 1)
+(defconstant +bz-finish+ 2)
+
+(defcfun ("BZ2_bzCompress" %bz-compress) :int
+ (bz-stream :pointer)
+ (action :int))
+
+(defun bz-compress (bz-stream action)
+ (flet ((!accept (code-designator)
+ (with-bz-error-handling ("BZ2_bzCompress" :accept code-designator)
+ (%bz-compress bz-stream action))))
+ (cond
+ ((= action +bz-run+)
+ (!accept +bz-run-ok+))
+ ((= action +bz-flush+)
+ (!accept +bz-flush-ok+))
+ ((= action +bz-finish+)
+ (!accept (list +bz-finish-ok+ +bz-stream-end+))))))
+
+(defcfun ("BZ2_bzCompressEnd" %bz-compress-end) :int
+ (bz-stream :pointer))
+
+(defun bz-compress-end (bz-stream)
+ (with-bz-error-handling ("BZ2_bzCompressEnd" :accept +bz-ok+)
+ (%bz-compress-end bz-stream)))
+
+;;; Wrappers over low-level decompress API
+
+(defcfun ("BZ2_bzDecompressInit" %bz-decompress-init) :int
+ (bz-stream :pointer)
+ (verbosity :int)
+ (small :int))
+
+(defun bz-decompress-init (bz-stream verbosity smallp)
+ (with-bz-error-handling ("BZ2_bzDecompressInit" :accept +bz-ok+)
+ (%bz-decompress-init bz-stream
+ verbosity
+ (if smallp 1 0))))
+
+(defcfun ("BZ2_bzDecompress" %bz-decompress) :int
+ (bz-stream :pointer))
+
+(defun bz-decompress (bz-stream)
+ (with-bz-error-handling ("BZ2_bzDecompress" :accept (list +bz-ok+ +bz-stream-end+))
+ (%bz-decompress bz-stream)))
+
+(defcfun ("BZ2_bzDecompressEnd" %bz-decompress-end) :int
+ (bz-strem :pointer))
+
+(defun bz-decompress-end (bz-stream)
+ (with-bz-error-handling ("BZ2_bzDecompressEnd" :accept +bz-ok+)
+ (%bz-decompress-end bz-stream)))
+
+;;;; Easy types
+
+(deftype octet ()
+ '(unsigned-byte 8))
+
+(deftype octet-vector ()
+ '(vector (unsigned-byte 8)))
+
+;;; High level stuff
+
+(defparameter *input-chunk-size* 4096)
+(defparameter *output-chunk-size* 4096)
+
+(defun write-to-lisp-stream (ptr stream length)
+ (loop
+ for i from 0 to (1- length)
+ do (write-byte (mem-aref ptr :uchar i) stream)))
+
+(defun vector->cvector-copy (vector cptr &optional (start 0) (end (length vector)))
+ (loop
+ for i from start to (1- end)
+ do (setf (mem-aref cptr :uchar i) (aref vector i))))
+
+(defstruct (array-container
+ (:constructor make-array-container-aux)
+ (:conc-name nil))
+ in-vec
+ in-cvec
+ out-cvec
+ input-chunk-size
+ output-chunk-size)
+
+(defun make-array-container (input-chunk-size output-chunk-size)
+ (make-array-container-aux
+ :in-vec (make-sequence 'octet-vector input-chunk-size)
+ :in-cvec (foreign-alloc :uchar :count input-chunk-size)
+ :out-cvec (foreign-alloc :uchar :count output-chunk-size)
+ :input-chunk-size input-chunk-size
+ :output-chunk-size output-chunk-size))
+
+(defun free-array-container (container)
+ (foreign-free (in-cvec container))
+ (foreign-free (out-cvec container)))
+
+(defmacro with-array-container ((var &key
+ (input-chunk-size '*input-chunk-size*)
+ (output-chunk-size '*output-chunk-size*))
+ &body body)
+ `(let ((,var (make-array-container ,input-chunk-size ,output-chunk-size)))
+ (unwind-protect (progn ,@body)
+ (free-array-container ,var))))
+
+;;;; High level compression calls
+
+(defun compress-stream-aux (bz-stream in-stream out-stream ac)
+ (let* ((input-chunk-size (input-chunk-size ac))
+ (output-chunk-size (output-chunk-size ac))
+ (in-vec (in-vec ac))
+ (in-size (read-sequence in-vec in-stream :start 0 :end input-chunk-size))
+ (in-cvec (in-cvec ac))
+ (out-cvec (out-cvec ac))
+ (input-left-p (= in-size input-chunk-size)))
+ (vector->cvector-copy in-vec in-cvec 0 in-size)
+ (with-foreign-slots ((next-in avail-in next-out avail-out) bz-stream bz-stream)
+ (setf next-in in-cvec
+ avail-in in-size)
+ ;; The following code is a translation from the C source of
+ ;; BZ2_bzWrite and BZ2_bzWriteClose64 in bzlib.c.
+ ;; Using action BZ_RUN
+ (block run
+ (loop
+ (setf next-out out-cvec
+ avail-out output-chunk-size)
+ ;; bzCompress/BZ_RUN
+ (bz-compress bz-stream +bz-run+)
+ (when (< avail-out output-chunk-size)
+ ;; Writing to output stream
+ (write-to-lisp-stream out-cvec out-stream (- output-chunk-size avail-out)))
+ (when (= avail-in 0)
+ (return-from run nil))))
+ ;; Using action BZ_FINISH, only if no more input is left
+ (unless input-left-p
+ (block finish
+ (loop
+ (setf next-out out-cvec
+ avail-out output-chunk-size)
+ (let ((return-code
+ ;; bzCompress/BZ_FINISH
+ (bz-compress bz-stream +bz-finish+)))
+ (when (< avail-out output-chunk-size)
+ ;; Writing to output stream
+ (write-to-lisp-stream out-cvec out-stream (- output-chunk-size avail-out)))
+ (when (= return-code +bz-stream-end+)
+ (return-from finish nil)))))))
+ (force-output out-stream)
+ ;; More input available?
+ input-left-p))
+
+(defparameter *block-size-100k* 9)
+(defparameter *verbosity* 0)
+(defparameter *work-factor* 30)
+
+(defun compress-stream (in-stream out-stream &key
+ (block-size-100k *block-size-100k*)
+ (verbosity *verbosity*)
+ (work-factor *work-factor*))
+ (with-bz-stream (bz-stream)
+ (bz-compress-init bz-stream block-size-100k verbosity work-factor)
+ (unwind-protect
+ (with-array-container (ac)
+ (loop
+ while (compress-stream-aux bz-stream in-stream out-stream ac)))
+ (bz-compress-end bz-stream)))
+ (values))
+
+(defun compress (in out &key
+ (block-size-100k *block-size-100k*)
+ (verbosity *verbosity*)
+ (work-factor *work-factor*))
+ "Compresses data from IN to OUT. IN or OUT can either be a binary
+ stream or a pathname.
+
+BLOCK-SIZE-100K, VERBOSITY and WORK-FACTOR correspond to the
+ parameters `blockSize100k', `verbosity' and `workFactor',
+ respectively, for the libbzip2 function `BZ2_bzCompressInit'."
+ (let ((*block-size-100k* block-size-100k)
+ (*verbosity* verbosity)
+ (*work-factor* work-factor))
+ (compress-aux in out)))
+
+(defgeneric compress-aux (in out)
+ (:documentation "Specialize behaviour for COMPRESS depending on IN and OUT."))
+
+(defmethod compress-aux ((in stream) (out stream))
+ (compress-stream in out))
+
+(defmethod compress-aux ((in pathname) out)
+ (with-open-file (in-stream in :direction :input :element-type 'octet)
+ (compress-aux in-stream out)))
+
+(defmethod compress-aux (in (out pathname))
+ (with-open-file (out-stream out :direction :output :element-type 'octet :if-exists :supersede)
+ (compress-aux in out-stream)))
+
+;;;; High level decompression calls
+
+(defun decompress-stream-aux (bz-stream in-stream out-stream ac)
+ (let* ((input-chunk-size (input-chunk-size ac))
+ (output-chunk-size (output-chunk-size ac))
+ (in-vec (in-vec ac))
+ (in-size (read-sequence in-vec in-stream :start 0 :end input-chunk-size))
+ (in-cvec (in-cvec ac))
+ (out-cvec (out-cvec ac))
+ (input-left-p (= in-size input-chunk-size)))
+ (vector->cvector-copy in-vec in-cvec 0 in-size)
+ (with-foreign-slots ((next-in avail-in next-out avail-out) bz-stream bz-stream)
+ (setf next-in in-cvec
+ avail-in in-size)
+ ;; bz_decompress
+ (block decompress
+ (loop
+ (setf next-out out-cvec
+ avail-out output-chunk-size)
+ (let ((return-code (bz-decompress bz-stream)))
+ (when (< avail-out output-chunk-size)
+ (write-to-lisp-stream out-cvec out-stream (- output-chunk-size avail-out)))
+ (when (or (= avail-in 0)
+ (= return-code +bz-stream-end+))
+ (return-from decompress nil)))))
+ ;; More input available?
+ input-left-p)))
+
+(defparameter *smallp* nil)
+
+(defun decompress-stream (in-stream out-stream &key
+ (verbosity *verbosity*)
+ (smallp *smallp*))
+ (with-bz-stream (bz-stream)
+ (bz-decompress-init bz-stream verbosity smallp)
+ (unwind-protect
+ (with-array-container (ac)
+ (loop
+ while (decompress-stream-aux bz-stream in-stream out-stream ac)))
+ (bz-decompress-end bz-stream)))
+ (values))
+
+(defun decompress (in out &key
+ (verbosity *verbosity*)
+ (smallp *smallp*))
+ "Decompresses data from IN to OUT. IN or OUT can either be a binary
+ stream or a pathname.
+
+VERBOSITY and SMALLP correspond to the parameters `verbosity' and
+ `workFactor', respectively, for the libbzip2 function
+ `BZ2_bzDecompressInit'."
+ (let ((*verbosity* verbosity)
+ (*smallp* smallp))
+ (decompress-aux in out)))
+
+(defgeneric decompress-aux (in out)
+ (:documentation "Specialize behaviour for DECOMPRESS depending on IN and OUT."))
+
+(defmethod decompress-aux ((in stream) (out stream))
+ (decompress-stream in out))
+
+(defmethod decompress-aux ((in pathname) out)
+ (with-open-file (in-stream in :direction :input :element-type 'octet)
+ (decompress-aux in-stream out)))
+
+(defmethod decompress-aux (in (out pathname))
+ (with-open-file (out-stream out :direction :output :element-type 'octet :if-exists :supersede)
+ (decompress-aux in out-stream)))
+
diff -rN -u old-cl-bzip2/cl-bzip2.asd new-cl-bzip2/cl-bzip2.asd
--- old-cl-bzip2/cl-bzip2.asd 1969-12-31 16:00:00.000000000 -0800
+++ new-cl-bzip2/cl-bzip2.asd 2014-07-29 03:48:27.000000000 -0700
@@ -0,0 +1,35 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; cl-bzip2.asd
+
+;;; Copyright (c) 2008, Chaitanya Gupta.
+;;; All rights reserved.
+;;;
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;; 1. Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+;;; 2. 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.
+;;; 3. The name of the author may not be used to endorse or promote products
+;;; derived from this software without specific prior written permission.
+;;;
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS 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 #:cl-bzip2
+ :depends-on (:cffi)
+ :serial t
+ :components ((:file "bzip2")
+ (:file "test")))
+
+
diff -rN -u old-cl-bzip2/test.lisp new-cl-bzip2/test.lisp
--- old-cl-bzip2/test.lisp 1969-12-31 16:00:00.000000000 -0800
+++ new-cl-bzip2/test.lisp 2014-07-29 03:48:27.000000000 -0700
@@ -0,0 +1,131 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
+;;; test.lisp
+
+;;; Copyright (c) 2008, Chaitanya Gupta.
+;;; All rights reserved.
+;;;
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;; 1. Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+;;; 2. 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.
+;;; 3. The name of the author may not be used to endorse or promote products
+;;; derived from this software without specific prior written permission.
+;;;
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS 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 #:cl-bzip2)
+
+(defvar *show-debug-info*)
+
+(defun debug-line (fmt &rest args)
+ (when *show-debug-info*
+ (apply #'format t (format nil "~&~A~%" fmt) args)
+ (force-output *standard-output*)))
+
+(defun test (file-path &key
+ (cleanup t)
+ (show-debug-info t)
+ (compress t)
+ (decompress t)
+ compare-file-contents
+ (block-size-100k *block-size-100k*)
+ (verbosity *verbosity*)
+ (work-factor *work-factor*)
+ (smallp *smallp*))
+ "Test compression/decompression.
+
+FILE-PATH is a path designator for the file to be tested. During
+compression, FILE-PATH.bz2 will be created. During decompression,
+FILE-PATH.new will be created. If CLEANUP is non-NIL,
+FILE-PATH.bz2 and FILE-PATH.new will be unconditionally deleted,
+regardless of whether they were created during this test or
+before.
+
+Setting SHOW-DEBUG-INFO to a non-NIL value sends some debugging
+info to *STANDARD-OUTPUT*.
+
+COMPRESS/DECOMRESS control whether compression/decompression is
+turned on or off. Both are turned on by default.
+
+COMPARE-FILE-CONTENTS compares the original and decompressed file
+byte by byte, otherwise the comparison is just over file length.
+
+For other parameters, see COMPRESS and DECOMPRESS."
+ (let* ((*show-debug-info* show-debug-info)
+ (test-file-path (namestring file-path))
+ (compressed-file-path (format nil "~A.bz2" test-file-path))
+ (new-file-path (format nil "~A.new" test-file-path))
+ (test-file-length nil)
+ (new-file-length nil))
+ (macrolet ((with-file ((var file dir) &body body)
+ `(with-open-file (,var
+ ,file
+ :direction ,dir
+ :element-type 'octet
+ :if-exists :supersede)
+ ,@body)))
+ (when compress
+ (with-file (in test-file-path :input)
+ (setf test-file-length (file-length in))
+ (debug-line "Original file size is ~A bytes." test-file-length)
+ (debug-line "Compressing...")
+ (with-file (out compressed-file-path :output)
+ (compress in out
+ :block-size-100k block-size-100k
+ :verbosity verbosity
+ :work-factor work-factor)
+ (unless decompress
+ (debug-line "Compressed file size is ~A bytes." (file-length out))))))
+ (when decompress
+ (with-file (in compressed-file-path :input)
+ (debug-line "Compressed file size is ~A bytes." (file-length in))
+ (debug-line "Decompressing...")
+ (with-file (out new-file-path :output)
+ (decompress in out
+ :verbosity verbosity
+ :smallp smallp)))
+ (with-file (in new-file-path :input)
+ (setf new-file-length (file-length in))
+ (debug-line "Decompressed file size is ~A bytes." new-file-length))))
+ (prog1
+ (when (and test-file-length new-file-length)
+ (and (= test-file-length new-file-length)
+ (if compare-file-contents
+ (progn
+ (debug-line "Comparing file contents...")
+ (file-contents= test-file-path new-file-path))
+ t)))
+ (when cleanup
+ (and (probe-file compressed-file-path) (delete-file compressed-file-path))
+ (and (probe-file new-file-path) (delete-file new-file-path))))))
+
+(defparameter *file-compare-sequence-length* 4096)
+
+(defun file-contents= (file1 file2)
+ (with-open-file (in1 file1 :direction :input :element-type 'octet)
+ (with-open-file (in2 file2 :direction :input :element-type 'octet)
+ (let ((seq1 (make-sequence 'octet-vector *file-compare-sequence-length*))
+ (seq2 (make-sequence 'octet-vector *file-compare-sequence-length*)))
+ (loop
+ for p1 = (read-sequence seq1 in1)
+ for p2 = (read-sequence seq2 in2)
+ until (and (zerop p1) (zerop p2))
+ when (not (and (= p1 p2)
+ (every #'= (subseq seq1 0 p1) (subseq seq2 0 p2))))
+ return nil
+ finally (return t))))))
+
+