-
Notifications
You must be signed in to change notification settings - Fork 42
/
zlib.lisp
167 lines (149 loc) · 5.72 KB
/
zlib.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
;;; cl-pdf copyright 2002-2009 Marc Battyani see license.txt for the details
;;; You can reach me at [email protected] or [email protected]
;;; 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)
(deflate::string-to-octets string 0 (length string))
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)))))
;;; salza2 zlib
#+use-salza2-zlib
(defun load-zlib (&optional force)
(declare (ignore force))
(setf *compress-streams* t))
;; string-to-octets copied from the original salza
#+use-salza2-zlib
(defun string-to-octets (string start end)
"Convert STRING to a sequence of octets, if possible."
(declare (type string string)
(type fixnum start end)
(optimize (speed 3) (safety 0)))
#+(and sbcl (not octet-characters))
(sb-ext:string-to-octets string :external-format :iso-8859-1 :start start :end end)
#+(and allegro (not octet-characters))
(excl:string-to-octets string :external-format :octets :start start :end end :null-terminate nil)
#+(and clisp (not octet-characters))
(ext:convert-string-to-bytes string custom:*default-file-encoding* :start start :end end)
#+(and ccl (not octet-characters))
(ccl:encode-string-to-octets string :external-format :latin-1 :start start :end end)
#+(and cmu (not octet-characters))
(ext:string-to-octets string :external-format :iso-8859-1 :start start :end end)
#+(or octet-characters lispworks abcl ecl)
(let* ((length (- end start))
(result (make-array length :element-type 'salza2::octet)))
(loop for i fixnum from start below end
for j fixnum from 0
do (setf (aref result j) (char-code (aref string i))))
result)
#+(and (not octet-characters) (not (or sbcl allegro clisp ccl cmu lispworks abcl ecl)))
(error "Do not know how to convert a string to octets."))
#+use-salza2-zlib
(defun compress-string (string)
(let ((input (if (stringp string)
(string-to-octets string 0 (length string))
string))
(chunks ()))
(flet ((cb (octet-vector end)
(push (subseq octet-vector 0 end)
chunks)))
(let ((compressor
(make-instance 'salza2:zlib-compressor
:callback #'cb)))
(salza2:compress-octet-vector input compressor)
(salza2:finish-compression compressor)))
(reverse 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)