-
Notifications
You must be signed in to change notification settings - Fork 0
/
t-gzip.cl
174 lines (156 loc) · 6.38 KB
/
t-gzip.cl
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
168
169
170
171
172
173
174
;; copyright (c) 2011-2012 Franz Inc, Oakland, CA - All rights reserved.
;;
;; The software, data and information contained herein are proprietary
;; to, and comprise valuable trade secrets of, Franz, Inc. They are
;; given in confidence by Franz, Inc. pursuant to a written license
;; agreement, and may be stored and used only in accordance with the terms
;; of such license.
;;
;; Restricted Rights Legend
;; ------------------------
;; Use, duplication, and disclosure of the software, data and information
;; contained herein by any agency, department or entity of the U.S.
;; Government are subject to restrictions of Restricted Rights for
;; Commercial Software developed at private expense as specified in
;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
(eval-when (compile load eval)
(require :deflate)
(require :inflate)
(require :test))
(in-package :test)
(defun deflate-file (input-filename output-filename &optional (type :gzip))
(with-open-file (in input-filename :direction :input)
(with-open-file (out output-filename
:direction :output
:if-exists :supersede)
(let ((buffer (make-array 4096 :element-type '(unsigned-byte 8)))
(deflate (make-instance 'util.zip::deflate-stream
:target out
:compression type)))
(loop
(let ((bytes (read-vector buffer in)))
(if* (zerop bytes) then (return))
(let ((pos 0))
(loop
(setq pos (write-vector buffer deflate :start pos :end bytes))
(if* (>= pos bytes) then (return)))
)))
; finish compression
(close deflate)))))
(defun inflate-file (input-filename output-filename &optional (type :gzip))
(with-open-file (in input-filename :direction :input)
(with-open-file (out output-filename
:direction :output
:if-exists :supersede)
(format t ";; Inside inflate-file~%")
(let ((inflate (make-instance 'util.zip::inflate-stream
:compression type
:input-handle in))
byte)
(while (setq byte (read-byte inflate nil nil))
(write-byte byte out))))))
(defun deflate-test (input-filename)
;; compress input-file to temp-file1, uncompress it back to temp-file2
;; and compare temp-file2 to input-filename, error if not same.
(flet ((cygwin-namestring (p)
#+mswindows (substitute #\/ #\\ (namestring p))
#-mswindows p))
(let (temp-file1 temp-file2)
(unwind-protect
(progn
(setq temp-file1 (sys:make-temp-file-name "deflate1x"))
(setq temp-file2 (sys:make-temp-file-name "deflate2x"))
(format t "; compress test on ~a~%"
(enough-namestring input-filename))
(deflate-file input-filename temp-file1)
(format t "; uncompress ~a to ~a~%" temp-file1 temp-file2)
(or (eql 0 (run-shell-command
(format nil "sh -c 'gunzip -d < ~a > ~a'"
(cygwin-namestring temp-file1)
(cygwin-namestring temp-file2))
:show-window :hide))
(error "gunzip failed on ~a" temp-file1))
;;(format t "; compare ~a to ~a~%" input-filename temp-file2)
(test-t (excl::compare-files input-filename temp-file2)))
(when temp-file1 (ignore-errors (delete-file temp-file1)))
(when temp-file2 (ignore-errors (delete-file temp-file2)))))))
(defun inflate-test (input-filename)
;; compress input-file to temp-file1, uncompress it back to temp-file2
;; and compare temp-file2 to input-filename, error if not same.
(flet ((cygwin-namestring (p)
#+mswindows (substitute #\/ #\\ (namestring p))
#-mswindows p))
(let (temp-file1 temp-file2)
(unwind-protect
(progn
(setq temp-file1 (sys:make-temp-file-name "inflate1x"))
(setq temp-file2 (sys:make-temp-file-name "inflate2x"))
(format t "; uncompress test on ~a~%"
(enough-namestring input-filename))
(format t "; compress ~a to ~a~%" temp-file1 temp-file2)
(or (eql 0 (run-shell-command
(format nil "sh -c 'gzip -c ~a > ~a'"
(cygwin-namestring input-filename)
(cygwin-namestring temp-file1))
:show-window :hide))
(error "gzip failed on ~a" temp-file1))
(inflate-file temp-file1 temp-file2)
;;(format t "; compare ~a to ~a~%" input-filename temp-file2)
(test-t (excl::compare-files input-filename temp-file2)))
(when temp-file1 (ignore-errors (delete-file temp-file1)))
(when temp-file2 (ignore-errors (delete-file temp-file2)))))))
(defun full-test (input-filename type &optional inflate-type)
;; compress input-file to temp-file1, uncompress it back to temp-file2
;; and compare temp-file2 to input-filename, error if not same.
(unless inflate-type
(setq inflate-type type))
(let (temp-file1 temp-file2)
(unwind-protect
(progn
(setq temp-file1 (sys:make-temp-file-name "full1"))
(setq temp-file2 (sys:make-temp-file-name "full2"))
(format t "; full test on ~a type ~s ~s~%"
(enough-namestring input-filename) type inflate-type)
(format t " ; deflate ~a to ~a~%" temp-file1 temp-file2)
(deflate-file input-filename temp-file1 type)
(format t " ; inflate ~a to ~a~%" temp-file1 temp-file2)
(inflate-file temp-file1 temp-file2 inflate-type)
;;(format t "; compare ~a to ~a~%" input-filename temp-file2)
(test-t (excl::compare-files input-filename temp-file2)))
(when temp-file1 (ignore-errors (delete-file temp-file1)))
(when temp-file2 (ignore-errors (delete-file temp-file2))))))
;; skip the 2-byte zlib header
(defun custom-zlib-head (p)
(read-byte p) (read-byte p)
2)
;; skip the 4-byte zlib trailer
(defun custom-zlib-tail (p)
(dotimes (i 4) (read-byte p))
4)
(defun test-invalid-first-byte-in-header ()
(let ((in-file "/dev/zero"))
(dolist (type '(:gzip :zlib))
(format t "~&Testing faulty header detection (~s)..." type)
(with-open-file (in in-file :direction :input)
(test-no-err (make-instance 'util.zip::inflate-stream
:compression type
:input-handle in)))
(format t "okay.~%"))))
(defun test-gzip ()
(map-over-directory
(lambda (p)
;; Only check .cl files. This test file may be run in
;; a directory with many large files resulting in
;; the test taking a _very_ long time.
(when (string-equal "cl" (pathname-type p))
(deflate-test p)
(inflate-test p)
(dolist (type '(:gzip :zlib :deflate nil))
(full-test p type))
;; test custom compression type.
(full-test p :zlib '(custom-zlib-head custom-zlib-tail))
))
"./"
:recurse nil)
(test-invalid-first-byte-in-header))
(when *do-test* (do-test "gzip" #'test-gzip))