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
  58 (defun compressor-designator-compressor (designator initargs)
  59   (etypecase designator
  60     (symbol (apply #'make-instance designator initargs))
  61     (deflate-compressor designator)))
  62
  63 (defun compress-data (data compressor-designator &rest initargs)
  64   (let ((chunks '())
  65         (size 0)
  66         (compressor (compressor-designator-compressor compressor-designator
  67                                                       initargs)))
  68     (setf (callback compressor)
  69           (lambda (buffer end)
  70             (incf size end)
  71             (push (subseq buffer 0 end)
  72                   chunks)))
  73     (compress-octet-vector data compressor)
  74     (finish-compression compressor)
  75     (let ((compressed (make-array size :element-type '(unsigned-byte 8)))
  76           (start 0))
  77       (dolist (chunk (nreverse chunks))
  78         (replace compressed chunk :start1 start)
  79         (incf start (length chunk)))
  80       compressed)))