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

Contents of /zip/zip.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5