user.lisp

   1 ;;;; $Id: user.lisp,v 1.1 2007/12/20 21:04:19 xach Exp $
   2
   3 (in-package #:salza2)
   4
   5 (defmacro with-compressor ((var &key (class 'zlib-compressor) callback)
   6                            &body body)
   7   `(let ((,var (make-instance ,class
   8                               ,@(when callback (list :callback callback)))))
   9      (multiple-value-prog1
  10          (progn ,@body)
  11        (finish-compression ,var))))
  12
  13 (defun gzip-stream (input output)
  14   (let ((callback (lambda (data end)
  15                     (write-sequence data
  16                                     output
  17                                     :end end)))
  18         (buffer (make-array 8192 :element-type '(unsigned-byte 8))))
  19     (with-compressor (compressor :class 'gzip-compressor
  20                                  :callback callback)
  21       (loop
  22        (let ((end (read-sequence buffer input)))
  23          (when (zerop end)
  24            (return))
  25          (compress-octet-vector buffer compressor :end end))))))
  26
  27 (defun gzip-file (input output &key (if-exists :supersede))
  28   (with-open-file (istream input :element-type '(unsigned-byte 8))
  29     (with-open-file (ostream output
  30                              :element-type '(unsigned-byte 8)
  31                              :direction :output
  32                              :if-exists if-exists)
  33       (gzip-stream istream ostream)))
  34   (probe-file output))
  35
  36 (defun compress-data (data compressor-class)
  37   (let ((chunks '())
  38         (size 0))
  39     (with-compressor (compressor :class compressor-class
  40                                  :callback (lambda (buffer end)
  41                                              (incf size end)
  42                                              (push (subseq buffer 0 end)
  43                                                    chunks)))
  44       (salza2:compress-octet-vector data compressor))
  45     (let ((compressed (make-array size :element-type '(unsigned-byte 8)))
  46           (start 0))
  47       (dolist (chunk (nreverse chunks))
  48         (replace compressed chunk :start1 start)
  49         (incf start (length chunk)))
  50       compressed)))
  51
  52 (defun deflate-compress (data)
  53   (compress-data data 'deflate-compressor))
  54
  55 (defun zlib-compress (data)
  56   (compress-data data 'zlib-compressor))
  57
  58 (defun gzip-compress (data)
  59   (compress-data data 'gzip-compressor))
  60
  61
  62