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

Contents of /zip/zip.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Tue Apr 5 14:04:30 2005 UTC (9 years ago) by dlichteblau
Branch: MAIN
Changes since 1.2: +8 -6 lines
don't call salza functions for empty subsequences
(thanks to Edi Weitz for the bugreport)
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
214 #+allegro (excl:find-external-format :default)
215 #-allegro :dummy))
216 (let* (#+allegro (excl:*locale* (excl:find-locale :latin1))
217 (s (open pathname :element-type '(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 (z name data)
248 (setf name (substitute #\/ #\\ name))
249 (let* (#+allegro (excl:*locale* (excl:find-locale :latin1))
250 (s (zipwriter-stream z))
251 (header (make-local-header))
252 (utf8-name (string-to-octets name (zipwriter-external-format z)))
253 (entry (make-zipwriter-entry
254 :name name
255 :position (file-position s)
256 :header header)))
257 (setf (file/signature header) #x04034b50)
258 (setf (file/version-needed-to-extract header) 2) ;XXX ist das 2.0?
259 (setf (file/flags header) 8) ;bit 3: descriptor folgt nach daten
260 (setf (file/method header) 8)
261 (setf (file/time header) 0) ;XXX fixme
262 (setf (file/date header) 0) ;XXX fixme
263 (setf (file/crc header) 0)
264 (setf (file/compressed-size header) 0)
265 (setf (file/size header) 0)
266 (setf (file/name-length header) (length utf8-name))
267 (setf (file/extra-length header) 0)
268 (setf (zipwriter-tail z)
269 (setf (cdr (zipwriter-tail z)) (cons entry nil)))
270 (write-sequence header s)
271 (write-sequence utf8-name s)
272 (let ((descriptor (make-data-descriptor)))
273 (multiple-value-bind (nin nout crc)
274 (compress data s)
275 (setf (data/crc descriptor) crc)
276 (setf (data/compressed-size descriptor) nout)
277 (setf (data/size descriptor) nin)
278 ;; record same values for central directory
279 (setf (file/crc header) crc)
280 (setf (file/compressed-size header) nout)
281 (setf (file/size header) nin))
282 (write-sequence descriptor s))
283 name))
284
285 (defun write-central-directory (z)
286 (let* (#+allegro (excl:*locale* (excl:find-locale :latin1))
287 (s (zipwriter-stream z))
288 (pos (file-position s))
289 (n 0))
290 (dolist (e (cdr (zipwriter-head z)))
291 (incf n)
292 (let ((header (zipwriter-entry-header e))
293 (entry (make-directory-entry)))
294 (setf (cd/signature entry) #x02014b50)
295 (setf (cd/version-made-by entry) 0) ;dos compatible
296 (setf (cd/version-needed-to-extract entry)
297 (file/version-needed-to-extract header))
298 (setf (cd/flags entry) (file/flags header))
299 (setf (cd/method entry) (file/method header))
300 (setf (cd/time entry) (file/time header))
301 (setf (cd/date entry) (file/date header))
302 (setf (cd/crc entry) (file/crc header))
303 (setf (cd/compressed-size entry) (file/compressed-size header))
304 (setf (cd/size entry) (file/size header))
305 (setf (cd/name-length entry) (file/name-length header))
306 (setf (cd/extra-length entry) (file/extra-length header))
307 (setf (cd/comment-length entry) 0)
308 (setf (cd/disc-number entry) 0) ;XXX ?
309 (setf (cd/internal-attributes entry) 0)
310 (setf (cd/external-attributes entry) 0) ;XXX directories
311 (setf (cd/offset entry) (zipwriter-entry-position e))
312 (write-sequence entry s)
313 (write-sequence
314 (string-to-octets (zipwriter-entry-name e)
315 (zipwriter-external-format z))
316 s)))
317 (let ((end (make-end-header)))
318 (setf (end/signature end) #x06054b50)
319 (setf (end/this-disc end) 0) ;?
320 (setf (end/central-directory-disc end) 0) ;?
321 (setf (end/disc-files end) n)
322 (setf (end/total-files end) n)
323 (setf (end/central-directory-size end) (- (file-position s) pos))
324 (setf (end/central-directory-offset end) pos)
325 (setf (end/comment-length end) 0)
326 (write-sequence end s))))
327
328 (defmethod zipfile-entry-contents ((entry zipfile-entry) &optional stream)
329 (let (#+allegro (excl:*locale* (excl:find-locale :latin1))
330 (s (zipfile-entry-stream entry))
331 header)
332 (file-position s (zipfile-entry-offset entry))
333 (setf header (make-local-header s))
334 (assert (= (file/signature header) #x04034b50))
335 (file-position s (+ (file-position s)
336 (file/name-length header)
337 (file/extra-length header)))
338 (let ((in (make-instance 'truncating-stream
339 :input-handle s
340 :size (zipfile-entry-compressed-size entry)))
341 (outbuf nil)
342 out)
343 (if stream
344 (setf out stream)
345 (setf outbuf (make-byte-array (zipfile-entry-size entry))
346 out (make-buffer-output-stream outbuf)))
347 (ecase (file/method header)
348 (0 (store in out))
349 (8 (inflate in out)))
350 outbuf)))
351
352 (defmacro with-zipfile ((file pathname &key external-format) &body body)
353 `(let ((,file (open-zipfile ,pathname
354 ,@(when external-format
355 `(:external-format ,external-format)))))
356 (unwind-protect
357 (progn ,@body)
358 (close-zipfile ,file))))
359
360 (defun make-zipfile-writer
361 (pathname &key (if-exists :error)
362 (external-format
363 #+allegro (excl:find-external-format :default)
364 #-allegro :dummy))
365 (let (#+allegro (excl:*locale* (excl:find-locale :latin1))
366 (c (cons nil nil)))
367 (make-zipwriter
368 :stream (open pathname
369 :direction :output
370 :if-exists if-exists
371 :element-type '(unsigned-byte 8))
372 :external-format external-format
373 :head c
374 :tail c)))
375
376 (defun close-zipfile-writer (z)
377 (write-central-directory z)
378 (close (zipwriter-stream z)))
379
380 (defmacro with-output-to-zipfile
381 ((var pathname &key (if-exists :error)) &body body)
382 `(let ((,var (make-zipfile-writer ,pathname :if-exists ,if-exists)))
383 (unwind-protect
384 (progn ,@body)
385 (close-zipfile-writer ,var))))
386
387 (defmacro do-zipfile-entries ((name entry zipfile) &body body)
388 (setf name (or name (gensym)))
389 (setf entry (or entry (gensym)))
390 `(block nil
391 (maphash (lambda (,name ,entry)
392 (declare (ignorable ,name ,entry))
393 ,@body)
394 (zipfile-entries ,zipfile))))
395
396 (defun unzip (pathname target-directory &key (if-exists :error) verbose)
397 (when (or (pathname-name target-directory)
398 (pathname-type target-directory))
399 (error "pathname not a directory, lacks trailing slash?"))
400 (with-zipfile (zip pathname)
401 (do-zipfile-entries (name entry zip)
402 (let ((filename (merge-pathnames name target-directory)))
403 (ensure-directories-exist filename)
404 (unless (char= (elt name (1- (length name))) #\/)
405 (ecase verbose
406 ((nil))
407 ((t) (write-string name) (terpri))
408 (:dots (write-char #\.)))
409 (force-output)
410 (with-open-file
411 (s filename :direction :output :if-exists if-exists
412 :element-type '(unsigned-byte 8))
413 (zipfile-entry-contents entry s)))))))
414
415 (defun directoryp (pathname)
416 #+allegro (excl:file-directory-p pathname)
417 #-allegro (and (null (pathname-name pathname))
418 (null (pathname-type pathname))))
419
420 (defun zip (pathname source-directory &key (if-exists :error))
421 (with-output-to-zipfile (zip pathname :if-exists if-exists)
422 (labels ((recurse (d)
423 (dolist (f #+allegro (directory d :directories-are-files nil)
424 #-allegro (directory d))
425 (cond
426 ((directoryp f)
427 (write-zipentry
428 zip
429 (enough-namestring (namestring f) source-directory)
430 (make-concatenated-stream))
431 (recurse #+allegro f
432 #-allegro (make-pathname
433 :name :wild
434 :type :wild
435 :defaults f)))
436 ((or (pathname-name f) (pathname-type f))
437 (with-open-file (s f :element-type '(unsigned-byte 8))
438 (write-zipentry
439 zip
440 (enough-namestring (namestring f) source-directory)
441 s)))))))
442 (recurse source-directory))))

  ViewVC Help
Powered by ViewVC 1.1.5