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

Contents of /zip/zip.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5