user.lisp

   1 ;;;
   2 ;;; Copyright (c) 2007 Zachary Beane, All Rights Reserved
   3 ;;;
   4 ;;; Redistribution and use in source and binary forms, with or without
   5 ;;; modification, are permitted provided that the following conditions
   6 ;;; are met:
   7 ;;;
   8 ;;;   * Redistributions of source code must retain the above copyright
   9 ;;;     notice, this list of conditions and the following disclaimer.
  10 ;;;
  11 ;;;   * Redistributions in binary form must reproduce the above
  12 ;;;     copyright notice, this list of conditions and the following
  13 ;;;     disclaimer in the documentation and/or other materials
  14 ;;;     provided with the distribution.
  15 ;;;
  16 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  17 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  18 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  19 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  20 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  21 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  22 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  23 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  24 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  25 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  26 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  27 ;;;
  28
  29 (in-package #:salza2)
  30
  31 (defun make-stream-output-callback (stream)
  32   "Return a function suitable for use as a compressor callback that
  33 writes all compressed data to STREAM."
  34   (lambda (buffer end)
  35     (write-sequence buffer stream :end end)))
  36
  37 (defun gzip-stream (input output)
  38   (let ((callback (make-stream-output-callback output))
  39         (buffer (make-array 8192 :element-type '(unsigned-byte 8))))
  40     (with-compressor (compressor 'gzip-compressor
  41                                  :callback callback)
  42       (loop
  43        (let ((end (read-sequence buffer input)))
  44          (when (zerop end)
  45            (return))
  46          (compress-octet-vector buffer compressor :end end))))))
  47
  48 (defun gzip-file (input output &key (if-exists :supersede))
  49   (with-open-file (istream input :element-type '(unsigned-byte 8))
  50     (with-open-file (ostream output
  51                              :element-type '(unsigned-byte 8)
  52                              :direction :output
  53                              :if-exists if-exists)
  54       (gzip-stream istream ostream)))
  55   (probe-file output))
  56
  57 (defun compress-data (data compressor-class)
  58   (let ((chunks '())
  59         (size 0))
  60     (with-compressor (compressor compressor-class
  61                                  :callback (lambda (buffer end)
  62                                              (incf size end)
  63                                              (push (subseq buffer 0 end)
  64                                                    chunks)))
  65       (salza2:compress-octet-vector data compressor))
  66     (let ((compressed (make-array size :element-type '(unsigned-byte 8)))
  67           (start 0))
  68       (dolist (chunk (nreverse chunks))
  69         (replace compressed chunk :start1 start)
  70         (incf start (length chunk)))
  71       compressed)))
  72
  73 (defun deflate-compress (data)
  74   (compress-data data 'deflate-compressor))
  75
  76 (defun zlib-compress (data)
  77   (compress-data data 'zlib-compressor))
  78
  79 (defun gzip-compress (data)
  80   (compress-data data 'gzip-compressor))
  81
  82
  83