root/trunk/thirdparty/cl-pdf/zlib.lisp

;;; cl-pdf copyright 2002-2005 Marc Battyani see license.txt for the details
;;; You can reach me at marc.battyani@fractalconcept.com or marc@battyani.net
;;; The homepage of cl-pdf is here: http://www.fractalconcept.com/asp/html/cl-pdf.html

(in-package #:pdf)

;;; UFFI zlib

#+use-uffi-zlib
(defun load-zlib (&optional force)
  (when force (setf *zlib-loaded* nil))
  (unless *zlib-loaded*
    (let ((zlib-path (find-zlib-path)))
      (if zlib-path
          (progn
            (format t "~&;;; Loading ~s" zlib-path)
            (uffi:load-foreign-library zlib-path
                                       :module "zlib" 
                                       :supporting-libraries '("c"))
            (uffi:def-function ("compress" c-compress)
                ((dest (* :unsigned-char))
                 (destlen (* :long))
                 (source :cstring)
                 (source-len :long))
              :returning :int
              :module "zlib")
            (setf *zlib-loaded* t *compress-streams* t))
          (progn
            (warn "Unable to load zlib. Disabling compression.")
            (setf *compress-streams* nil))))))

#+use-uffi-zlib
(defun compress-string (source)
  "Returns two values: array of bytes containing the compressed data
 and the numbe of compressed bytes"
  (let* ((sourcelen (length source))
         (destsize (+ 12 (ceiling (* sourcelen 1.01))))
         (dest (uffi:allocate-foreign-string destsize :unsigned t))
         (destlen (uffi:allocate-foreign-object :long)))
    (setf (uffi:deref-pointer destlen :long) destsize)
    (uffi:with-cstring (source-native source)
      (let ((result (c-compress dest destlen source-native sourcelen))
            (newdestlen (uffi:deref-pointer destlen :long)))
        (unwind-protect
             (if (zerop result)
                 (values (uffi:convert-from-foreign-string 
                          dest
;                         :external-format '(:latin-1 :eol-style :lf)
                          :length newdestlen
                          :null-terminated-p nil)
                         newdestlen)
                 (error "zlib error, code ~D" result))
          (progn
            (uffi:free-foreign-object destlen)
            (uffi:free-foreign-object dest)))))))

;;; ABCL zlib

#+use-abcl-zlib
(defun load-zlib (&optional force)
  (declare (ignore force))
  (setf *compress-streams* t))

#+use-abcl-zlib
(defun compress-string (string)
  (let* ((string-bytes
          (java:jcall
           (java:jmethod "java.lang.String" "getBytes" "java.lang.String") string "UTF-8"))
         (out-array (java:jnew (java:jconstructor "java.io.ByteArrayOutputStream")))
         (compresser (java:jnew (java:jconstructor "java.util.zip.Deflater" "int")
                                (java:jfield "java.util.zip.Deflater" "BEST_COMPRESSION")))
         (defl-out-stream
          (java:jnew
           (java:jconstructor
            "java.util.zip.DeflaterOutputStream" "java.io.OutputStream" "java.util.zip.Deflater")
           out-array compresser)))
    (java:jcall (java:jmethod "java.util.zip.Deflater" "setInput" "[B") compresser string-bytes)
      (java:jcall (java:jmethod "java.util.zip.DeflaterOutputStream" "close") defl-out-stream)
      (java:jcall (java:jmethod "java.io.ByteArrayOutputStream" "toString") out-array)))

;;; salza zlib

#+use-salza-zlib
(defun load-zlib (&optional force)
  (declare (ignore force))
  (setf *compress-streams* t))

#+use-salza-zlib
(defun compress-string (string)
  (let* ((input (if (stringp string)
                    (babel::string-to-octets string :encoding :iso-8859-1)
                    string))
         (buffer-size (min 8192 (* 2 (length string))))
         (zlib-buffer (make-array buffer-size :element-type 'salza::octet))
         (chunks ()))
    (flet ((zlib-callback (zlib-stream)
             (push (subseq (salza::zlib-stream-buffer zlib-stream) 
                           0 (salza::zlib-stream-position zlib-stream)) chunks)
             (setf (salza::zlib-stream-position zlib-stream) 0)))
      (let ((zlib-stream (salza::make-zlib-stream zlib-buffer :callback #'zlib-callback)))
        (salza::zlib-write-sequence input zlib-stream)
        (salza::finish-zlib-stream zlib-stream)
        (nreverse chunks)))))

;;; no-zlib
#+use-no-zlib
(defun load-zlib (&optional force)
  (declare (ignore force))
  (setf *compress-streams* nil))

#+use-no-zlib
(defun compress-string (string)
  string)

;;; load it!

(load-zlib)