Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 578 lines (425 sloc) 16.96 kb
8dab617 @dklayer Add defpatch forms for 8.2
dklayer authored
1 #+(version= 8 2)
d5776c2 bug20472. Update defpatch form for deflate fix.
Mikel Bancroft authored
2 (sys:defpatch "deflate" 3
6dc661e @dklayer rfe10416: load libz.so.1
dklayer authored
3 "v0: new deflate-stream;
bdcf2b0 defpatch changed
John Foderaro authored
4 v1: load zlib.so.1 instead of zlib.so;
d5776c2 bug20472. Update defpatch form for deflate fix.
Mikel Bancroft authored
5 v2: fix memory leak.
6 v3: Add support for creating :gzip, :zlib, or raw :deflates streams."
8dab617 @dklayer Add defpatch forms for 8.2
dklayer authored
7 :type :system
8 :post-loadable t)
9
08627ae add deflate-stream and improve inflate-stream
John Foderaro authored
10 ;; stream for doing compression
11 ;;
12 ;; code based on zlib.cl from AllegroGraph written by marijnh
12a11c8 @dklayer Update copyright date
dklayer authored
13 ;; while under contract with Franz.
14
64935ac @dklayer Update copyrights to 2015
dklayer authored
15 ;; copyright (c) 2012-2015 Franz Inc, Oakland, CA - All rights reserved.
12a11c8 @dklayer Update copyright date
dklayer authored
16 ;;
17 ;; The software, data and information contained herein are proprietary
18 ;; to, and comprise valuable trade secrets of, Franz, Inc. They are
19 ;; given in confidence by Franz, Inc. pursuant to a written license
20 ;; agreement, and may be stored and used only in accordance with the terms
21 ;; of such license.
08627ae add deflate-stream and improve inflate-stream
John Foderaro authored
22 ;;
12a11c8 @dklayer Update copyright date
dklayer authored
23 ;; Restricted Rights Legend
24 ;; ------------------------
25 ;; Use, duplication, and disclosure of the software, data and information
26 ;; contained herein by any agency, department or entity of the U.S.
27 ;; Government are subject to restrictions of Restricted Rights for
28 ;; Commercial Software developed at private expense as specified in
29 ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
30
08627ae add deflate-stream and improve inflate-stream
John Foderaro authored
31 (defpackage :util.zip
32 (:use :common-lisp :excl)
33 (:export #:deflate-stream
34 #:deflate-target-stream
35 #:deflate-stream-vector
36 #:deflate-stream-vector-combined))
37
38 (in-package :util.zip)
39
40
41
42 (eval-when (compile load eval)
43 (defconstant *zlib-in-buffer-size* (* 16 1024))
44 (defconstant *zlib-out-buffer-size* (* 17 1024))
45 )
46
47
48
49
50 ;; deflate-stream
51 ;;
52 ;; create via
53 ;; (make-instance 'deflate-stream :target stream-or-vector
54 ;; :compression ckind)
55 ;;
56 ;; The target argument is required. It says where to compressed
57 ;; data.
c43b5b2 bug20472. Improve mechanism for skipping headers/trailers
Mikel Bancroft authored
58 ;; The :compression argument is optional. It can be :gzip,
59 ;; :zlib, or :deflate. If not given :gzip is assumed
08627ae add deflate-stream and improve inflate-stream
John Foderaro authored
60 ;;
61 ;; If a stream is given as the :target then the compressed bytes
62 ;; are written to that stream as they are generated.
63 ;; You cannot count on the zlib module to generate
64 ;; compressed bytes immediately. The only time you can be sure
65 ;; that all the compressed bytes have been send to the stream
66 ;; is after you close the deflate-stream. After the deflate-stream
67 ;; is closed, the last bits of compressed data is written to
68 ;; the target stream and a force-output is done the target
69 ;; stream. The target stream is NOT closed.
70 ;;
71 ;; If the :target value is a simple vector of (unsigned-byte 8) then
72 ;; the compressed bytes are written to that vector. If that
73 ;; vector fills up then more vectors are allocated.
74 ;; After the deflate-stream is closed you can call
75 ;; deflate-stream-vector to retrieve all off the vectors that contain
76 ;; the compressed data. You can also call deflate-stream-vector-combined
77 ;; to create a single vector containing all of the compressed data.
78 ;;
79 ;;
80 ;; examples
81 ;; (setq str (make-instance 'deflate-stream :target (make-array 1000 :element-type '(unsigned-byte 8))))
82 ;; (dotimes (i 1000) (write-byte (mod i 30) str))
83 ;; (close str)
84 ;; (deflate-stream-vector-combined str)
85 ;;
86
8045482 @dklayer rfe10416: add minimal tests suite
dklayer authored
87 (eval-when (compile load eval) (require :util-string))
88
b6e674f @dklayer Further refinement of libz naming
dklayer authored
89 (excl:without-package-locks
90 (defvar sys::*zlib-system-library*
91 (excl::machine-case :host
92 ((:msx86 :msx86-64)
93 ;; I don't know of a source for a 64-bit version of this library,
94 ;; but it would be called this if there were one.
95 "zlib1.dll")
96 ((:macosx86 :macosx86-64) "libz.1.dylib")
1d42218 @dklayer define *zlib-system-library* on FreeBSD per ACL version
dklayer authored
97 ;;;; FreeBSD changes the name of this library more than other
98 ;;;; platforms, which seem to keep it static between releases.
99 ;;;; The values here are defined per ACL version, which seems the most
100 ;;;; sensible way to do it.
101 #+(version= 8 2) (:freebsd "libz.so.3")
cf219d5 Port to Panasonic ipp3
Duane Rettig authored
102 #+(version= 9 0) ((:freebsd :ipp3) "libz.so.5")
2787d83 Fix libz for new freebsd 32-bit version
Duane Rettig authored
103 #+(version= 10 0) (:ipp3 "libz.so.5") ;; [bug22946]
104 #+(version= 10 0) (:freebsd "libz.so.6") ;; [bug23032]
1bd33ea Fix deflate to work on 8.2
Duane Rettig authored
105 #+(version>= 9 0) (:freebsd-64 "libz.so.6")
b6e674f @dklayer Further refinement of libz naming
dklayer authored
106 (t (util.string:string+ "libz." sys::*dll-type* ".1"))))
107 )
108
109 (defvar *zlib-dll-loaded* nil)
110 (when (not *zlib-dll-loaded*)
111 (handler-case (load sys::*zlib-system-library* :system-library t :foreign t)
112 (error (c)
113 (error "~
7b79035 @dklayer rfe10416: tweak error message for no libz
dklayer authored
114 This Allegro CL module requires the compression library named libz ~
115 to be present for the deflate module to load properly. ~
b6e674f @dklayer Further refinement of libz naming
dklayer authored
116 See http://zlib.net for versions for various platforms. The ~
117 actual error:~% ~a" c)))
9c69a73 push :zlib-deflate on *features* if deflate.fasl is loaded
John Foderaro authored
118 (setq *zlib-dll-loaded* t))
119
08627ae add deflate-stream and improve inflate-stream
John Foderaro authored
120
9c69a73 push :zlib-deflate on *features* if deflate.fasl is loaded
John Foderaro authored
121 (pushnew :zlib-deflate *features*)
122 (provide :deflate)
08627ae add deflate-stream and improve inflate-stream
John Foderaro authored
123
124 (ff:def-foreign-type z-stream
125 (:struct (next-in (* :void)) ; next input byte
126 (avail-in :unsigned-int) ; number of bytes available at next-in
127 (total-in :unsigned-long) ; total nb of input bytes read so far
128
129 (next-out (* :void)) ; next output byte should be put there
130 (avail-out :unsigned-int) ; remaining free space at next_out
131 (total-out :unsigned-long) ; total nb of bytes output so far
132
133 (msg (* :char)) ; last error message, NULL if no error
134 (state (* :void)) ; not visible by applications
135
136 (zalloc (* :void)) ; used to allocate the internal state
137 (zfree (* :void)) ; used to free the internal state
138 (opaque (* :void)) ; private data object passed to zalloc and zfree
139
140 (data-type :int) ; best guess about the data type: binary or text
141 (adler :unsigned-long) ; adler32 value of the uncompressed data
142 (reserved :unsigned-long))) ; reserved for future use
143
144
145 (ff:def-foreign-type deflate-in-buffer
146 (:struct (buff (:array :unsigned-char #.*zlib-in-buffer-size*))))
147
148 (ff:def-foreign-type deflate-out-buffer
149 (:struct (buff (:array :unsigned-char #.*zlib-out-buffer-size*))))
150
151
152
153 (defmacro z-stream-slot (name obj)
154 `(ff:fslot-value-typed 'z-stream :c ,obj ',name))
155
156 (ff:def-foreign-call (deflate-init-2 "deflateInit2_")
157 ((stream (* z-stream))
158 (level :int)
159 (method :int)
160 (window-bits :int)
161 (mem-level :int)
162 (strategy :int)
163 (version (* :char))
164 (stream-size :int))
165 :strings-convert t
166 :returning :int)
167
168 (ff:def-foreign-call (deflate "deflate")
169 ((stream (* z-stream))
170 (flush :int))
171 :returning :int)
172
173 (ff:def-foreign-call (deflate-end "deflateEnd")
174 ((stream (* z-stream)))
175 :returning :int)
176
177
178 (def-stream-class deflate-stream (single-channel-simple-stream)
179 ((z-state
180 ;; malloc z-state foreign object
181 ;; holding the info zlib needs to use to run
182 :initform 0
183 :accessor z-state)
184
185 ; using existing slots
186 ; from stream
187 ; flags
188 ; output-handle - stream to vector
189 ; external-format
190 ;
191 ; from simple-stream
192 ; buffer malloc,ed, contains user written data
193 ; buffer-ptr next byte to write
194 ; charpos always nil since we don't track
195 ;
196 ;
197
198 ; new slots
199
200 (z-stream
201 ;; holds malloc'ed zlib struct that controls compression
202 :initform 0
203 :accessor zlib-z-stream)
204
205 (in-buffer
206 ;; malloced buffer to which data is copied before compression
207 ;; since the compressor requires a static buffer
208 :accessor zlib-in-buffer)
209
210
211 (z-buffer
212 ;; malloc buffer holding data after compression
213 ;; it's malloced so it stays still
214
215 :initform 0
216 :accessor zlib-z-buffer)
217
218
219 (in-buffer-ptr :initform 0
220 :accessor zlib-in-buffer-ptr)
221
222
223 ; points to the lispstatic-reclaimable resources for
224 ; this stream. Should the stream be dropped and never
225 ; closed this list will be gc'ed and that will the
226 ; allow the static data to be reclaimed.
227 (static-resources :initform nil
228 :accessor zlib-static-resources)
229
230 ; trace usage
231 (in-bytes :initform 0
232 :accessor zlib-in-bytes)
233
234 (out-bytes :initform 0
235 :accessor zlib-out-bytes)
236
237
238 ;; for stream target
239 (target-stream
240 :initform nil
241 :accessor deflate-target-stream)
242
243 ;; for vector target
244 (target-vector
245 :initform nil
246 :accessor zlib-target-vector)
247
248 (target-vector-pos
249 :initform 0
250 :accessor zlib-target-vector-pos)
251
252 (target-vector-old
253 ; list of full previous target vectors
254 :initform nil
255 :accessor zlib-target-vector-old)
256
257 ;; end vector target
258
259
260 )
261 )
262
263 (defmethod print-object ((p deflate-stream) s)
264 (print-unreadable-object (p s :identity t :type t)
265 (format s "in ~d / out ~d" (zlib-in-bytes p) (zlib-out-bytes p))))
266
267 (defmethod device-open ((p deflate-stream) dummy options)
268 (declare (ignore dummy))
269
270
271 (let ((output-target (getf options :target))
272 (compression (or (getf options :compression)
273 :gzip))
274 (static-resources (get-deflate-buffer-resources)))
275
276 (setf (zlib-static-resources p) static-resources)
277
278 (destructuring-bind (z-stream-vec in-buffer-vec out-buffer-vec)
279 static-resources
280
281
282 (typecase output-target
283 (stream
284 (setf (deflate-target-stream p) output-target))
285 ((simple-array (unsigned-byte 8) (*))
286 (setf (zlib-target-vector p) output-target))
287 (t (error "the value of initarg :target must be a stream or simple (unsigned-byte 8) vector, not ~s" output-target)))
288
c43b5b2 bug20472. Improve mechanism for skipping headers/trailers
Mikel Bancroft authored
289 (if* (not (member compression '(:gzip :zlib :deflate)))
290 then (error "compression must be :gzip, :zlib, or :deflate, not ~s"
08627ae add deflate-stream and improve inflate-stream
John Foderaro authored
291 compression))
292
293 (if* (null output-target)
294 then (error ":output-target must be given when creating a deflate-stream"))
295
296 ;; normal these would be written using the with-stream-class
297 ;; macro and sm, but we may want to open source this so best
298 ;; to write it in code that doesn't need a dcl to build
299 (setf
300 (slot-value p 'excl::buffer) (make-array 4096 :element-type '(unsigned-byte 8))
301 (zlib-in-buffer p) (ff:fslot-address-typed
302 'deflate-in-buffer
303 :foreign-static-gc
304 in-buffer-vec)
305
306
307 (zlib-z-buffer p) (ff:fslot-address-typed
308 'deflate-out-buffer
309 :foreign-static-gc
310 out-buffer-vec)
311
312 (slot-value p 'excl::buffer-ptr) 0
313
314 (zlib-z-stream p) (make-z-stream (ff:fslot-address-typed
315 'z-stream
316 :foreign-static-gc
317 z-stream-vec)
318
319 compression)
320
321 (slot-value p 'excl::control-out) excl::*std-control-out-table*
322
323 )
324
325 ; does some kind of initialization I think
326 (setf (stream-external-format p)
327 (stream-external-format p))
328
329 (add-stream-instance-flags p :output :simple)
330
331 t)))
332
333
334
335 (defun make-z-stream (z-stream type)
336 (let (
c43b5b2 bug20472. Improve mechanism for skipping headers/trailers
Mikel Bancroft authored
337 ;; windowBits default value is 15 for zlib header and trailer
338 ;; if you add 16 you get gzip header and trailer
339 ;; if windowBits is -15, then you get a raw deflate stream.
340 (window-bits (+ 15 (ecase type (:gzip 16) (:zlib 0) (:deflate -30)))))
08627ae add deflate-stream and improve inflate-stream
John Foderaro authored
341 (setf (z-stream-slot zalloc z-stream) 0
342 (z-stream-slot zfree z-stream) 0
343 (z-stream-slot opaque z-stream) 0)
344 (let ((err (deflate-init-2 z-stream
345 -1 #|default level|#
346 8 #|Z_DEFLATED|#
347 window-bits
348 8 #|default level|#
349 0 #|Z_DEFAULT_STRATEGY|#
350 "1.2.3.4" #|version|#
351 (ff:sizeof-fobject 'z-stream))))
352 (if* (< err 0 #|Z_OK|#)
353 then (error "deflateInit2_ returned ~a" err)))
354 z-stream))
355
44b5270 fix memory leak in deflate stream
John Foderaro authored
356 (defun finish-z-stream (z-stream)
357 ;; free C resources controlled by zlib
358 (deflate-end z-stream))
359
08627ae add deflate-stream and improve inflate-stream
John Foderaro authored
360
361
362 (defmethod device-write ((p deflate-stream) buffer start end blocking)
363 ;;
364 ;; buffer is an ausb8
365 ;;
366 ;; fill up the internal static buffer
367 ;; do the compressing should the buffer fill up
368 ;;
369 (declare (ignore blocking))
370
371 (let ((in-buffer (zlib-in-buffer p))
372 (in-buffer-ptr (zlib-in-buffer-ptr p))
373 (max *zlib-in-buffer-size*)
374 (buffer (or buffer (slot-value p 'excl::buffer)))
375 )
376
377
378 (do ((i start (1+ i)))
379 ((>= i end))
380
381
382 (setf (sys::memref-int in-buffer in-buffer-ptr 0 :unsigned-byte)
383 (aref buffer i))
384 (incf in-buffer-ptr)
385
386 (if* (>= in-buffer-ptr max)
387 then ; must flush the buffer
388 (setf (zlib-in-buffer-ptr p) in-buffer-ptr)
389 (flush-deflate-stream-input-buffer p)
390 (setq in-buffer-ptr (zlib-in-buffer-ptr p))))
391
392
393 (setf (zlib-in-buffer-ptr p) in-buffer-ptr)
394
395
396 end))
397
398
399 (defmethod flush-deflate-stream-input-buffer ((p deflate-stream))
400 ;; compress the contents of the input buffer
401
402 (let ((z-stream (zlib-z-stream p)))
403
404 (setf (z-stream-slot avail-in z-stream) (zlib-in-buffer-ptr p)
405 (z-stream-slot next-in z-stream) (zlib-in-buffer p))
406
407 (incf (zlib-in-bytes p) (zlib-in-buffer-ptr p))
408
409 (setf (zlib-in-buffer-ptr p) 0)
410
411 (loop
412 (if* (zerop (z-stream-slot avail-in z-stream))
413 then ; no more to compress
414 (return))
415
416
417 (setf (z-stream-slot next-out z-stream) (zlib-z-buffer p)
418 (z-stream-slot avail-out z-stream) *zlib-out-buffer-size*)
419
420 (let ((error (deflate z-stream 0 ; Z_NO_FLUSH
421 )))
422
423 (if* (< error 0)
424 then (error "zlib's deflate returned error code ~s" error))
425
426
427 (process-compressed-result p)))))
428
429 (defmethod finish-zlib-compression ((p deflate-stream))
430 ;; finish the compression of the contents of the input buffer
431
432
433 (flush-deflate-stream-input-buffer p)
434
435 (let ((z-stream (zlib-z-stream p)))
436
437
438
439 (loop
440 (setf (z-stream-slot next-out z-stream) (zlib-z-buffer p)
441 (z-stream-slot avail-out z-stream) *zlib-out-buffer-size*)
442
443 (let ((error (deflate z-stream 4 ; Z_FINISH
444 )))
445
446 (process-compressed-result p)
447 (if* (eq error 1) ; Z_STREAM_END
448 then (return))
449 ))))
450
451
452 (defmethod process-compressed-result ((p deflate-stream))
453 ;; take the resulant compressed bytes and put
454 ;; them somewhere
455
456 (let ((static-vec (zlib-z-buffer p))
457 (bytes (- *zlib-out-buffer-size*
458 (z-stream-slot avail-out (zlib-z-stream p)))))
459
460
461 (incf (zlib-out-bytes p) bytes)
462 ; we'll just write byte all the values
463
464 (let ((target-stream (deflate-target-stream p)))
465 (if* target-stream
466 then
467 (dotimes (i bytes)
468 (write-byte (sys:memref-int static-vec i 0 :unsigned-byte)
469 target-stream))
470 else (let* ((vec (zlib-target-vector p))
471 (pos (zlib-target-vector-pos p))
472 (max (length vec))
473 (static-base 0))
474
475 (loop
476 (let ((docopy (min bytes (- max pos))))
477
478 (dotimes (i docopy)
479 (setf (aref vec (+ pos i))
480 (sys:memref-int static-vec i static-base :unsigned-byte)))
481 (if* (> bytes docopy)
482 then ; we overflowed, more to do
483 (push vec (zlib-target-vector-old p))
484 (setq vec (make-array (length vec)
485 :element-type
486 '(unsigned-byte 8)))
487 (setf (zlib-target-vector p) vec)
488
489 (setq pos 0)
490 (incf static-base docopy)
491 (decf bytes docopy)
492
493 else ; finished
494 (setf (zlib-target-vector-pos p) (+ pos docopy))
495 (return)))))))))
496
497
498
499
500
501 (defmethod device-close ((p deflate-stream) abort)
502
503 (if* (not abort)
504 then ; flush all current data
505 (finish-zlib-compression p))
506
44b5270 fix memory leak in deflate stream
John Foderaro authored
507 (let ((z-stream (zlib-z-stream p)))
508 (if* (not (zerop z-stream))
509 then (finish-z-stream z-stream))
510 (setf (zlib-z-stream p) 0))
08627ae add deflate-stream and improve inflate-stream
John Foderaro authored
511
512 (if* (deflate-target-stream p)
513 then (force-output (deflate-target-stream p)))
3811035 avoid race in device-close [bug20559]
mm authored
514
515 ;; Free the Lisp resource only after all the uses of
516 ;; the static areas are done. [bug20559]
517 (free-deflate-buffer-resource (zlib-static-resources p))
518
08627ae add deflate-stream and improve inflate-stream
John Foderaro authored
519 p
520 )
521
522 (without-package-locks
523 (defmethod excl::inner-stream ((p deflate-stream))
524 (deflate-target-stream p)))
525
526
527 (defmethod deflate-stream-vector ((p deflate-stream))
528 (let ((vec (zlib-target-vector p)))
529 (if* vec
530 then (values vec
531 (zlib-target-vector-pos p)
532 (zlib-target-vector-old p))
533 else (error "deflate-stream ~s was not created with a vector target" p))))
534
535 (defmethod deflate-stream-vector-combined ((p deflate-stream))
536 (multiple-value-bind (last pos old) (deflate-stream-vector p)
537 (if* old
538 then ; must combine
539 (let ((size pos))
540 (dolist (v old) (incf size (length v)))
541 (let ((ans (make-array size :element-type '(unsigned-byte 8)))
542 (start 0))
543 (dolist (v (reverse old))
544 (replace ans v :start1 start)
545 (incf start (length v)))
546 (replace ans last :start1 start :end2 pos)
547 (values ans size)))
548 else (values last pos))))
549
550
551
552
553
554 ;; we'll resource the buffers we need to speed up allocation
555
556 (defvar *deflate-resource-lock* (mp:make-process-lock))
557
558 (defvar *deflate-malloc-resources* nil)
559
560
561
562 (defun get-deflate-buffer-resources ()
563 (mp:with-process-lock (*deflate-resource-lock*)
564 (let ((buffers (pop *deflate-malloc-resources*)))
565 (if* buffers
566 thenret
567 else (list (ff:allocate-fobject 'z-stream :foreign-static-gc)
568 (ff:allocate-fobject 'deflate-in-buffer :foreign-static-gc)
569 (ff:allocate-fobject 'deflate-out-buffer :foreign-static-gc))))))
570
571
572 (defun free-deflate-buffer-resource (buffers)
573 (mp:with-process-lock (*deflate-resource-lock*)
574 (push buffers *deflate-malloc-resources*)))
575
576
577
Something went wrong with that request. Please try again.