/[zip]/zip/zip.lisp
ViewVC logotype

Contents of /zip/zip.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Sun Apr 3 20:42:01 2005 UTC (9 years ago) by dlichteblau
Branch: MAIN
Changes since 1.1: +4 -13 lines
removed useless SUBSEQ
1 ;;;; Copyright (c) 2004,2005 David Lichteblau <david@lichteblau.com>
2 ;;;; Lizenz: (L)LGPL
3 ;;;;
4 ;;;; Urspruenglicher Autor: David Lichteblau.
5 ;;;; Aenderungen durch knowledgeTools GmbH.
6
7 ;;;; http://www.pkware.com/company/standards/appnote/
8
9 (in-package :zip)
10
11 (defun make-byte-array (n)
12 (make-array n :element-type '(unsigned-byte 8)))
13
14 (defun get-short (array offset)
15 (logior (elt array offset)
16 (ash (elt array (1+ offset)) 8)))
17
18 (defun (setf get-short) (newval array offset)
19 (setf (elt array (+ offset 0)) (logand newval #xff))
20 (setf newval (ash newval -8))
21 (setf (elt array (+ offset 1)) (logand newval #xff))
22 newval)
23
24 (defun get-int (array offset)
25 (logior (elt array offset)
26 (ash (elt array (+ offset 1)) 8)
27 (ash (elt array (+ offset 2)) 16)
28 (ash (elt array (+ offset 3)) 24)))
29
30 (defun (setf get-int) (newval array offset)
31 (setf (elt array (+ offset 0)) (logand newval #xff))
32 (setf newval (ash newval -8))
33 (setf (elt array (+ offset 1)) (logand newval #xff))
34 (setf newval (ash newval -8))
35 (setf (elt array (+ offset 2)) (logand newval #xff))
36 (setf newval (ash newval -8))
37 (setf (elt array (+ offset 3)) (logand newval #xff))
38 newval)
39
40 (defmacro define-record (constructor (&key (length (gensym))) &rest fields)
41 `(progn
42 (defconstant ,length
43 ,(loop
44 for (nil type) in fields
45 sum (ecase type (:int 4) (:short 2))))
46 (defun ,constructor (&optional s)
47 (let ((bytes (make-byte-array ,length)))
48 (when s
49 (read-sequence bytes s))
50 bytes))
51 ,@(loop
52 for (name type) in fields
53 for offset = 0 then (+ offset length)
54 for length = (ecase type (:int 4) (:short 2))
55 for reader = (ecase type (:int 'get-int) (:short 'get-short))
56 unless (eq name :dummy)
57 append `((defun ,name (r)
58 (,reader r ,offset))
59 (defun (setf ,name) (newval r)
60 (setf (,reader r ,offset) newval))))))
61
62 (define-record make-end-header (:length +end-header-length+)
63 (end/signature :int)
64 (end/this-disc :short)
65 (end/central-directory-disc :short)
66 (end/disc-files :short)
67 (end/total-files :short)
68 (end/central-directory-size :int)
69 (end/central-directory-offset :int)
70 (end/comment-length :short))
71
72 (define-record make-directory-entry ()
73 (cd/signature :int)
74 (cd/version-made-by :short)
75 (cd/version-needed-to-extract :short)
76 (cd/flags :short)
77 (cd/method :short)
78 (cd/time :short)
79 (cd/date :short)
80 (cd/crc :int)
81 (cd/compressed-size :int)
82 (cd/size :int)
83 (cd/name-length :short)
84 (cd/extra-length :short)
85 (cd/comment-length :short)
86 (cd/disc-number :short)
87 (cd/internal-attributes :short)
88 (cd/external-attributes :int)
89 (cd/offset :int))
90
91 (define-record make-local-header ()
92 (file/signature :int)
93 (file/version-needed-to-extract :short)
94 (file/flags :short)
95 (file/method :short)
96 (file/time :short)
97 (file/date :short)
98 (file/crc :int)
99 (file/compressed-size :int)
100 (file/size :int)
101 (file/name-length :short)
102 (file/extra-length :short))
103
104 (define-record make-data-descriptor ()
105 (data/crc :int)
106 (data/compressed-size :int)
107 (data/size :int))
108
109 (defun update-crc (crc buf &optional (end (length buf)))
110 (multiple-value-bind (high low)
111 (salza-deflate:crc32 (logxor (ldb (byte 16 16) crc) #xffff)
112 (logxor (ldb (byte 16 00) crc) #xffff)
113 buf
114 end)
115 (logior (ash (logxor high #xffff) 16) (logxor low #xffff))))
116
117 (defun compress (input output)
118 (let ((nin 0)
119 (nout 0)
120 (crc 0))
121 (flet ((flush-stream (zlib-stream)
122 (let ((start (if (zerop nout) 2 0))
123 (end (salza:zlib-stream-position zlib-stream)))
124 (write-sequence (salza::zlib-stream-buffer zlib-stream)
125 output
126 :start start
127 :end end)
128 (incf nout (- end start))
129 (setf (salza:zlib-stream-position zlib-stream) 0))))
130 (let* ((input-buffer (make-array 8192 :element-type '(unsigned-byte 8)))
131 (output-buffer (make-array 8192 :element-type '(unsigned-byte 8)))
132 (zlib-stream (salza:make-zlib-stream output-buffer
133 :callback #'flush-stream)))
134 (loop
135 (let ((end (read-sequence input-buffer input)))
136 (salza:zlib-write-sequence input-buffer zlib-stream :end end)
137 (incf nin end)
138 (setf crc (update-crc crc input-buffer end))
139 (when (zerop end)
140 (salza:finish-zlib-stream zlib-stream)
141 (return (values nin nout crc)))))))))
142
143 (defun store (in out)
144 "Copy uncompressed bytes from IN to OUT and return values like COMPRESS."
145 (let ((buf (make-array 8192
146 :initial-element 0
147 :element-type '(unsigned-byte 8)))
148 (ntotal 0)
149 (crc 0))
150 (loop
151 for n = (read-sequence buf in :end (length buf))
152 until (zerop n)
153 do
154 (write-sequence buf out :end n)
155 (incf ntotal n)
156 (setf crc (update-crc crc buf n)))
157 (values ntotal ntotal crc)))
158
159 (defun seek-to-end-header (s)
160 (let* ((len (+ 65536 +end-header-length+))
161 (guess (max 0 (- (file-length s) len))))
162 (file-position s guess)
163 (let ((v (make-byte-array (min (file-length s) len))))
164 (read-sequence v s)
165 (let ((n (search #(80 75 5 6) v :from-end t)))
166 (unless n
167 (error "end of central directory header not found"))
168 (file-position s (+ guess n))))))
169
170 (defstruct zipfile
171 stream
172 entries
173 external-format)
174
175 (defstruct zipfile-entry
176 name
177 stream
178 offset
179 size
180 compressed-size)
181
182 (defstruct zipwriter
183 stream
184 head
185 tail
186 external-format)
187
188 (defstruct zipwriter-entry
189 name
190 position
191 header)
192
193 (defun read-entry-object (s external-format)
194 (let* ((header (make-directory-entry s))
195 (name (make-array (cd/name-length header)
196 :element-type '(unsigned-byte 8))))
197 (assert (= (cd/signature header) #x02014b50))
198 (read-sequence name s)
199 (setf name (octets-to-string name external-format))
200 (prog1
201 (make-zipfile-entry :name name
202 :stream s
203 :offset (cd/offset header)
204 :size (cd/size header)
205 :compressed-size (cd/compressed-size header))
206 (file-position s (+ (file-position s)
207 (cd/extra-length header)
208 (cd/comment-length header))))))
209
210 (defun open-zipfile
211 (pathname &key (external-format
212 #+allegro (excl:find-external-format :default)
213 #-allegro :dummy))
214 (let* (#+allegro (excl:*locale* (excl:find-locale :latin1))
215 (s (open pathname :element-type '(unsigned-byte 8))))
216 (unwind-protect
217 (progn
218 (seek-to-end-header s)
219 (let* ((end (make-end-header s))
220 (n (end/total-files end))
221 (entries (make-hash-table :test #'equal))
222 (zipfile (make-zipfile :stream s
223 :entries entries
224 :external-format external-format)))
225 (file-position s (end/central-directory-offset end))
226 (dotimes (x n)
227 (let ((entry (read-entry-object s external-format)))
228 (setf (gethash (zipfile-entry-name entry) entries) entry)))
229 #+sbcl (let ((s s)) (sb-ext:finalize zipfile (lambda ()(close s))))
230 (setf s nil)
231 zipfile))
232 (when s
233 (close s)))))
234
235 (defgeneric close-zipfile (zipfile))
236 (defgeneric get-zipfile-entry (name zipfile))
237 (defgeneric zipfile-entry-contents (entry &optional stream))
238
239 (defmethod close-zipfile ((zipfile zipfile))
240 (close (zipfile-stream zipfile)))
241
242 (defmethod get-zipfile-entry (name (zipfile zipfile))
243 (gethash name (zipfile-entries zipfile)))
244
245 (defun write-zipentry (z name data)
246 (setf name (substitute #\/ #\\ name))
247 (let* (#+allegro (excl:*locale* (excl:find-locale :latin1))
248 (s (zipwriter-stream z))
249 (header (make-local-header))
250 (utf8-name (string-to-octets name (zipwriter-external-format z)))
251 (entry (make-zipwriter-entry
252 :name name
253 :position (file-position s)
254 :header header)))
255 (setf (file/signature header) #x04034b50)
256 (setf (file/version-needed-to-extract header) 2) ;XXX ist das 2.0?
257 (setf (file/flags header) 8) ;bit 3: descriptor folgt nach daten
258 (setf (file/method header) 8)
259 (setf (file/time header) 0) ;XXX fixme
260 (setf (file/date header) 0) ;XXX fixme
261 (setf (file/crc header) 0)
262 (setf (file/compressed-size header) 0)
263 (setf (file/size header) 0)
264 (setf (file/name-length header) (length utf8-name))
265 (setf (file/extra-length header) 0)
266 (setf (zipwriter-tail z)
267 (setf (cdr (zipwriter-tail z)) (cons entry nil)))
268 (write-sequence header s)
269 (write-sequence utf8-name s)
270 (let ((descriptor (make-data-descriptor)))
271 (multiple-value-bind (nin nout crc)
272 (compress data s)
273 (setf (data/crc descriptor) crc)
274 (setf (data/compressed-size descriptor) nout)
275 (setf (data/size descriptor) nin)
276 ;; record same values for central directory
277 (setf (file/crc header) crc)
278 (setf (file/compressed-size header) nout)
279 (setf (file/size header) nin))
280 (write-sequence descriptor s))
281 name))
282
283 (defun write-central-directory (z)
284 (let* (#+allegro (excl:*locale* (excl:find-locale :latin1))
285 (s (zipwriter-stream z))
286 (pos (file-position s))
287 (n 0))
288 (dolist (e (cdr (zipwriter-head z)))
289 (incf n)
290 (let ((header (zipwriter-entry-header e))
291 (entry (make-directory-entry)))
292 (setf (cd/signature entry) #x02014b50)
293 (setf (cd/version-made-by entry) 0) ;dos compatible
294 (setf (cd/version-needed-to-extract entry)
295 (file/version-needed-to-extract header))
296 (setf (cd/flags entry) (file/flags header))
297 (setf (cd/method entry) (file/method header))
298 (setf (cd/time entry) (file/time header))
299 (setf (cd/date entry) (file/date header))
300 (setf (cd/crc entry) (file/crc header))
301 (setf (cd/compressed-size entry) (file/compressed-size header))
302 (setf (cd/size entry) (file/size header))
303 (setf (cd/name-length entry) (file/name-length header))
304 (setf (cd/extra-length entry) (file/extra-length header))
305 (setf (cd/comment-length entry) 0)
306 (setf (cd/disc-number entry) 0) ;XXX ?
307 (setf (cd/internal-attributes entry) 0)
308 (setf (cd/external-attributes entry) 0) ;XXX directories
309 (setf (cd/offset entry) (zipwriter-entry-position e))
310 (write-sequence entry s)
311 (write-sequence
312 (string-to-octets (zipwriter-entry-name e)
313 (zipwriter-external-format z))
314 s)))
315 (let ((end (make-end-header)))
316 (setf (end/signature end) #x06054b50)
317 (setf (end/this-disc end) 0) ;?
318 (setf (end/central-directory-disc end) 0) ;?
319 (setf (end/disc-files end) n)
320 (setf (end/total-files end) n)
321 (setf (end/central-directory-size end) (- (file-position s) pos))
322 (setf (end/central-directory-offset end) pos)
323 (setf (end/comment-length end) 0)
324 (write-sequence end s))))
325
326 (defmethod zipfile-entry-contents ((entry zipfile-entry) &optional stream)
327 (let (#+allegro (excl:*locale* (excl:find-locale :latin1))
328 (s (zipfile-entry-stream entry))
329 header)
330 (file-position s (zipfile-entry-offset entry))
331 (setf header (make-local-header s))
332 (assert (= (file/signature header) #x04034b50))
333 (file-position s (+ (file-position s)
334 (file/name-length header)
335 (file/extra-length header)))
336 (let ((in (make-instance 'truncating-stream
337 :input-handle s
338 :size (zipfile-entry-compressed-size entry)))
339 (outbuf nil)
340 out)
341 (if stream
342 (setf out stream)
343 (setf outbuf (make-byte-array (zipfile-entry-size entry))
344 out (make-buffer-output-stream outbuf)))
345 (ecase (file/method header)
346 (0 (store in out))
347 (8 (inflate in out)))
348 outbuf)))
349
350 (defmacro with-zipfile ((file pathname &key external-format) &body body)
351 `(let ((,file (open-zipfile ,pathname
352 ,@(when external-format
353 `(:external-format ,external-format)))))
354 (unwind-protect
355 (progn ,@body)
356 (close-zipfile ,file))))
357
358 (defun make-zipfile-writer
359 (pathname &key (if-exists :error)
360 (external-format
361 #+allegro (excl:find-external-format :default)
362 #-allegro :dummy))
363 (let (#+allegro (excl:*locale* (excl:find-locale :latin1))
364 (c (cons nil nil)))
365 (make-zipwriter
366 :stream (open pathname
367 :direction :output
368 :if-exists if-exists
369 :element-type '(unsigned-byte 8))
370 :external-format external-format
371 :head c
372 :tail c)))
373
374 (defun close-zipfile-writer (z)
375 (write-central-directory z)
376 (close (zipwriter-stream z)))
377
378 (defmacro with-output-to-zipfile
379 ((var pathname &key (if-exists :error)) &body body)
380 `(let ((,var (make-zipfile-writer ,pathname :if-exists ,if-exists)))
381 (unwind-protect
382 (progn ,@body)
383 (close-zipfile-writer ,var))))
384
385 (defmacro do-zipfile-entries ((name entry zipfile) &body body)
386 (setf name (or name (gensym)))
387 (setf entry (or entry (gensym)))
388 `(block nil
389 (maphash (lambda (,name ,entry)
390 (declare (ignorable ,name ,entry))
391 ,@body)
392 (zipfile-entries ,zipfile))))
393
394 (defun unzip (pathname target-directory &key (if-exists :error) verbose)
395 (when (or (pathname-name target-directory)
396 (pathname-type target-directory))
397 (error "pathname not a directory, lacks trailing slash?"))
398 (with-zipfile (zip pathname)
399 (do-zipfile-entries (name entry zip)
400 (let ((filename (merge-pathnames name target-directory)))
401 (ensure-directories-exist filename)
402 (unless (char= (elt name (1- (length name))) #\/)
403 (ecase verbose
404 ((nil))
405 ((t) (write-string name) (terpri))
406 (:dots (write-char #\.)))
407 (force-output)
408 (with-open-file
409 (s filename :direction :output :if-exists if-exists
410 :element-type '(unsigned-byte 8))
411 (zipfile-entry-contents entry s)))))))
412
413 (defun directoryp (pathname)
414 #+allegro (excl:file-directory-p pathname)
415 #-allegro (and (null (pathname-name pathname))
416 (null (pathname-type pathname))))
417
418 (defun zip (pathname source-directory &key (if-exists :error))
419 (with-output-to-zipfile (zip pathname :if-exists if-exists)
420 (labels ((recurse (d)
421 (dolist (f #+allegro (directory d :directories-are-files nil)
422 #-allegro (directory d))
423 (cond
424 ((directoryp f)
425 (write-zipentry
426 zip
427 (enough-namestring (namestring f) source-directory)
428 (make-concatenated-stream))
429 (recurse #+allegro f
430 #-allegro (make-pathname
431 :name :wild
432 :type :wild
433 :defaults f)))
434 ((or (pathname-name f) (pathname-type f))
435 (with-open-file (s f :element-type '(unsigned-byte 8))
436 (write-zipentry
437 zip
438 (enough-namestring (namestring f) source-directory)
439 s)))))))
440 (recurse source-directory))))

  ViewVC Help
Powered by ViewVC 1.1.5