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

Contents of /zip/zip.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (show annotations)
Wed Jan 2 21:00:01 2008 UTC (6 years, 3 months ago) by dlichteblau
Branch: MAIN
CVS Tags: HEAD
Changes since 1.10: +18 -31 lines
switched to salza2, thanks to Zach Beane
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 compress (input output compressor)
113 (let ((nin 0)
114 (nout 0)
115 (crc (make-instance 'salza2:crc32-checksum)))
116 (flet ((callback (buffer count)
117 (write-sequence buffer output :start 0 :end count)
118 (incf nout count)))
119 (setf (salza2:callback compressor) #'callback)
120 (let* ((input-buffer (make-array 8192 :element-type '(unsigned-byte 8))))
121 (loop
122 (let ((end (read-sequence input-buffer input)))
123 (cond
124 ((plusp end)
125 (salza2:compress-octet-vector input-buffer compressor :end end)
126 (incf nin end)
127 (salza2:update crc input-buffer 0 end))
128 (t
129 (salza2:finish-compression compressor)
130 (salza2:reset compressor)
131 (return (values nin nout (salza2:result crc)))))))))))
132
133 (defun store (in out)
134 "Copy uncompressed bytes from IN to OUT and return values like COMPRESS."
135 (let ((buf (make-array 8192
136 :initial-element 0
137 :element-type '(unsigned-byte 8)))
138 (ntotal 0)
139 (crc (make-instance 'salza2:crc32-checksum)))
140 (loop
141 for n = (read-sequence buf in :end (length buf))
142 until (zerop n)
143 do
144 (write-sequence buf out :end n)
145 (incf ntotal n)
146 (salza2:update crc buf 0 n))
147 (values ntotal ntotal (salza2:result crc))))
148
149 (defun seek-to-end-header (s)
150 (let* ((len (+ 65536 +end-header-length+))
151 (guess (max 0 (- (file-length s) len))))
152 (file-position s guess)
153 (let ((v (make-byte-array (min (file-length s) len))))
154 (read-sequence v s)
155 (let ((n (search #(80 75 5 6) v :from-end t)))
156 (unless n
157 (error "end of central directory header not found"))
158 (file-position s (+ guess n))))))
159
160 (defstruct zipfile
161 stream
162 entries
163 external-format)
164
165 (defstruct zipfile-entry
166 name
167 stream
168 offset
169 size
170 compressed-size
171 comment)
172
173 (defstruct zipwriter
174 stream
175 compressor
176 head
177 tail
178 external-format)
179
180 (defstruct zipwriter-entry
181 name
182 position
183 header)
184
185 (defun read-entry-object (s external-format)
186 (let* ((header (make-directory-entry s))
187 (name (make-array (cd/name-length header)
188 :element-type '(unsigned-byte 8)))
189 (comment
190 (when (plusp (cd/comment-length header))
191 (make-array (cd/comment-length header)
192 :element-type '(unsigned-byte 8)))))
193 (assert (= (cd/signature header) #x02014b50))
194 (read-sequence name s)
195 (setf name (octets-to-string name external-format))
196 (file-position s (+ (file-position s) (cd/extra-length header)))
197 (when comment
198 (read-sequence comment s)
199 (setf comment (octets-to-string comment external-format)))
200 (make-zipfile-entry :name name
201 :stream s
202 :offset (cd/offset header)
203 :size (cd/size header)
204 :compressed-size (cd/compressed-size header)
205 :comment comment)))
206
207 (defun open-zipfile
208 (pathname &key (external-format (default-external-format)))
209 (let* ((s (open pathname
210 #-allegro :element-type
211 #-allegro '(unsigned-byte 8))))
212 (unwind-protect
213 (progn
214 (seek-to-end-header s)
215 (let* ((end (make-end-header s))
216 (n (end/total-files end))
217 (entries (make-hash-table :test #'equal))
218 (zipfile (make-zipfile :stream s
219 :entries entries
220 :external-format external-format)))
221 (file-position s (end/central-directory-offset end))
222 (dotimes (x n)
223 (let ((entry (read-entry-object s external-format)))
224 (setf (gethash (zipfile-entry-name entry) entries) entry)))
225 #+sbcl (let ((s s)) (sb-ext:finalize zipfile (lambda ()(close s))))
226 (setf s nil)
227 zipfile))
228 (when s
229 (close s)))))
230
231 (defgeneric close-zipfile (zipfile))
232 (defgeneric get-zipfile-entry (name zipfile))
233 (defgeneric zipfile-entry-contents (entry &optional stream))
234
235 (defmethod close-zipfile ((zipfile zipfile))
236 (close (zipfile-stream zipfile)))
237
238 (defmethod get-zipfile-entry (name (zipfile zipfile))
239 (gethash name (zipfile-entries zipfile)))
240
241 (defun write-zipentry
242 (z name data &key (file-write-date (file-write-date data)))
243 (setf name (substitute #\/ #\\ name))
244 (let* ((s (zipwriter-stream z))
245 (header (make-local-header))
246 (utf8-name (string-to-octets name (zipwriter-external-format z)))
247 (entry (make-zipwriter-entry
248 :name name
249 :position (file-position s)
250 :header header)))
251 (setf (file/signature header) #x04034b50)
252 (setf (file/version-needed-to-extract header) 2) ;XXX ist das 2.0?
253 (setf (file/flags header) 8) ;bit 3: descriptor folgt nach daten
254 (setf (file/method header) 8)
255 (multiple-value-bind (s min h d m y)
256 (decode-universal-time
257 (or file-write-date (encode-universal-time 0 0 0 1 1 1980 0)))
258 (setf (file/time header)
259 (logior (ash h 11) (ash min 5) (ash s -1)))
260 (setf (file/date header)
261 (logior (ash (- y 1980) 9) (ash m 5) d)))
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 (zipwriter-compressor z))
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* ((s (zipwriter-stream z))
285 (pos (file-position s))
286 (n 0))
287 (dolist (e (cdr (zipwriter-head z)))
288 (incf n)
289 (let ((header (zipwriter-entry-header e))
290 (entry (make-directory-entry)))
291 (setf (cd/signature entry) #x02014b50)
292 (setf (cd/version-made-by entry) 20) ;version 2.0, fat
293 (setf (cd/version-needed-to-extract entry)
294 (file/version-needed-to-extract header))
295 (setf (cd/flags entry) (file/flags header))
296 (setf (cd/method entry) (file/method header))
297 (setf (cd/time entry) (file/time header))
298 (setf (cd/date entry) (file/date header))
299 (setf (cd/crc entry) (file/crc header))
300 (setf (cd/compressed-size entry) (file/compressed-size header))
301 (setf (cd/size entry) (file/size header))
302 (setf (cd/name-length entry) (file/name-length header))
303 (setf (cd/extra-length entry) (file/extra-length header))
304 (setf (cd/comment-length entry) 0)
305 (setf (cd/disc-number entry) 0) ;XXX ?
306 (setf (cd/internal-attributes entry) 0)
307 (setf (cd/external-attributes entry) 0) ;XXX directories
308 (setf (cd/offset entry) (zipwriter-entry-position e))
309 (write-sequence entry s)
310 (write-sequence
311 (string-to-octets (zipwriter-entry-name e)
312 (zipwriter-external-format z))
313 s)))
314 (let ((end (make-end-header)))
315 (setf (end/signature end) #x06054b50)
316 (setf (end/this-disc end) 0) ;?
317 (setf (end/central-directory-disc end) 0) ;?
318 (setf (end/disc-files end) n)
319 (setf (end/total-files end) n)
320 (setf (end/central-directory-size end) (- (file-position s) pos))
321 (setf (end/central-directory-offset end) pos)
322 (setf (end/comment-length end) 0)
323 (write-sequence end s))))
324
325 (defmethod zipfile-entry-contents ((entry zipfile-entry) &optional stream)
326 (let ((s (zipfile-entry-stream entry))
327 header)
328 (file-position s (zipfile-entry-offset entry))
329 (setf header (make-local-header s))
330 (assert (= (file/signature header) #x04034b50))
331 (file-position s (+ (file-position s)
332 (file/name-length header)
333 (file/extra-length header)))
334 (let ((in (make-instance 'truncating-stream
335 :input-handle s
336 :size (zipfile-entry-compressed-size entry)))
337 (outbuf nil)
338 out)
339 (if stream
340 (setf out stream)
341 (setf outbuf (make-byte-array (zipfile-entry-size entry))
342 out (make-buffer-output-stream outbuf)))
343 (ecase (file/method header)
344 (0 (store in out))
345 (8 (inflate in out)))
346 outbuf)))
347
348 (defmacro with-zipfile ((file pathname &key external-format) &body body)
349 `(let ((,file (open-zipfile ,pathname
350 ,@(when external-format
351 `(:external-format ,external-format)))))
352 (unwind-protect
353 (progn ,@body)
354 (close-zipfile ,file))))
355
356 (defun make-zipfile-writer
357 (pathname &key (if-exists :error)
358 (external-format (default-external-format)))
359 (let ((c (cons nil nil)))
360 (make-zipwriter
361 :stream (open pathname
362 :direction :output
363 :if-exists if-exists
364 :element-type '(unsigned-byte 8))
365 :compressor (make-instance 'salza2:deflate-compressor)
366 :external-format external-format
367 :head c
368 :tail c)))
369
370 (defun close-zipfile-writer (z)
371 (write-central-directory z)
372 (close (zipwriter-stream z)))
373
374 (defmacro with-output-to-zipfile
375 ((var pathname &key (if-exists :error)) &body body)
376 `(let ((,var (make-zipfile-writer ,pathname :if-exists ,if-exists)))
377 (unwind-protect
378 (progn ,@body)
379 (close-zipfile-writer ,var))))
380
381 (defmacro do-zipfile-entries ((name entry zipfile) &body body)
382 (setf name (or name (gensym)))
383 (setf entry (or entry (gensym)))
384 `(block nil
385 (maphash (lambda (,name ,entry)
386 (declare (ignorable ,name ,entry))
387 ,@body)
388 (zipfile-entries ,zipfile))))
389
390 (defun unzip (pathname target-directory &key (if-exists :error) verbose)
391 ;; <Xof> "When reading[1] the value of any pathname component, conforming
392 ;; programs should be prepared for the value to be :unspecific."
393 (when (set-difference (list (pathname-name target-directory)
394 (pathname-type target-directory))
395 '(nil :unspecific))
396 (error "pathname not a directory, lacks trailing slash?"))
397 (with-zipfile (zip pathname)
398 (do-zipfile-entries (name entry zip)
399 (let ((filename (merge-pathnames name target-directory)))
400 (ensure-directories-exist filename)
401 (unless (char= (elt name (1- (length name))) #\/)
402 (ecase verbose
403 ((nil))
404 ((t) (write-string name) (terpri))
405 (:dots (write-char #\.)))
406 (force-output)
407 (with-open-file
408 (s filename :direction :output :if-exists if-exists
409 :element-type '(unsigned-byte 8))
410 (zipfile-entry-contents entry s)))))))
411
412 (defun %directoryp (pathname)
413 #+allegro (excl:file-directory-p pathname)
414 #+lispworks (lispworks:file-directory-p pathname)
415 #+clisp (ignore-errors
416 (ext:probe-directory
417 (concatenate 'string (princ-to-string pathname) "/")))
418 #-(or lispworks allegro clisp)
419 (and (null (pathname-name pathname))
420 (null (pathname-type pathname))))
421
422 (defun %directory (d)
423 #+allegro (directory d :directories-are-files nil)
424 #+clisp (append (directory (concatenate 'string (princ-to-string d) "/*/"))
425 (directory (concatenate 'string (princ-to-string d) "/*")))
426 #-(or allegro clisp) (directory d))
427
428 (defun %file-write-date (f)
429 #+clisp (posix:file-stat-mtime (posix:file-stat f))
430 #-clisp (file-write-date f))
431
432 (defun %pathname-for-directory (f)
433 #+(or allegro clisp) f
434 #-(or allegro clisp) (make-pathname :name :wild :type :wild :defaults f))
435
436 (defun %directory-namestring (d)
437 #+clisp (directory-namestring
438 (truename (concatenate 'string (princ-to-string d) "/")))
439 #-clisp (directory-namestring d))
440
441 (defun zip (pathname source-directory &key (if-exists :error))
442 (let ((base (%directory-namestring (merge-pathnames source-directory))))
443 (with-output-to-zipfile (zip pathname :if-exists if-exists)
444 (labels ((recurse (d)
445 (dolist (f (%directory d))
446 (cond
447 ((%directoryp f)
448 (write-zipentry
449 zip
450 (enough-namestring (namestring f) base)
451 (make-concatenated-stream)
452 :file-write-date (%file-write-date f))
453 (recurse (%pathname-for-directory f)))
454 ((or (pathname-name f) (pathname-type f))
455 (with-open-file (s f :element-type '(unsigned-byte 8))
456 (write-zipentry
457 zip
458 (enough-namestring (namestring f) base)
459 s)))))))
460 (recurse source-directory)))))

  ViewVC Help
Powered by ViewVC 1.1.5