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

Contents of /zip/zip.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Sun Apr 3 19:36:28 2005 UTC (9 years ago) by dlichteblau
Branch: MAIN
Branch point for: dlichteblau
Initial revision
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 (let
139 ;; fixme
140 ((b (if (eql end (length input-buffer))
141 input-buffer
142 (subseq input-buffer 0 end))))
143 (setf crc (update-crc crc b)))
144 (when (zerop end)
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 ;; Compute CRC using R. Matthew Emerson's Lisp implementation instead of
156 ;; zlib's CRC function, since STORE is (only) useful in the absence of
157 ;; zlib anyway.
158 (loop
159 for n = (read-sequence buf in :end (length buf))
160 until (zerop n)
161 do
162 (write-sequence buf out :end n)
163 (incf ntotal n)
164 (let ((b (if (eql n (length buf)) buf (subseq buf 0 n))))
165 (setf crc (update-crc crc b))))
166 (values ntotal ntotal crc)))
167
168 (defun seek-to-end-header (s)
169 (let* ((len (+ 65536 +end-header-length+))
170 (guess (max 0 (- (file-length s) len))))
171 (file-position s guess)
172 (let ((v (make-byte-array (min (file-length s) len))))
173 (read-sequence v s)
174 (let ((n (search #(80 75 5 6) v :from-end t)))
175 (unless n
176 (error "end of central directory header not found"))
177 (file-position s (+ guess n))))))
178
179 (defstruct zipfile
180 stream
181 entries
182 external-format)
183
184 (defstruct zipfile-entry
185 name
186 stream
187 offset
188 size
189 compressed-size)
190
191 (defstruct zipwriter
192 stream
193 head
194 tail
195 external-format)
196
197 (defstruct zipwriter-entry
198 name
199 position
200 header)
201
202 (defun read-entry-object (s external-format)
203 (let* ((header (make-directory-entry s))
204 (name (make-array (cd/name-length header)
205 :element-type '(unsigned-byte 8))))
206 (assert (= (cd/signature header) #x02014b50))
207 (read-sequence name s)
208 (setf name (octets-to-string name external-format))
209 (prog1
210 (make-zipfile-entry :name name
211 :stream s
212 :offset (cd/offset header)
213 :size (cd/size header)
214 :compressed-size (cd/compressed-size header))
215 (file-position s (+ (file-position s)
216 (cd/extra-length header)
217 (cd/comment-length header))))))
218
219 (defun open-zipfile
220 (pathname &key (external-format
221 #+allegro (excl:find-external-format :default)
222 #-allegro :dummy))
223 (let* (#+allegro (excl:*locale* (excl:find-locale :latin1))
224 (s (open pathname :element-type '(unsigned-byte 8))))
225 (unwind-protect
226 (progn
227 (seek-to-end-header s)
228 (let* ((end (make-end-header s))
229 (n (end/total-files end))
230 (entries (make-hash-table :test #'equal))
231 (zipfile (make-zipfile :stream s
232 :entries entries
233 :external-format external-format)))
234 (file-position s (end/central-directory-offset end))
235 (dotimes (x n)
236 (let ((entry (read-entry-object s external-format)))
237 (setf (gethash (zipfile-entry-name entry) entries) entry)))
238 #+sbcl (let ((s s)) (sb-ext:finalize zipfile (lambda ()(close s))))
239 (setf s nil)
240 zipfile))
241 (when s
242 (close s)))))
243
244 (defgeneric close-zipfile (zipfile))
245 (defgeneric get-zipfile-entry (name zipfile))
246 (defgeneric zipfile-entry-contents (entry &optional stream))
247
248 (defmethod close-zipfile ((zipfile zipfile))
249 (close (zipfile-stream zipfile)))
250
251 (defmethod get-zipfile-entry (name (zipfile zipfile))
252 (gethash name (zipfile-entries zipfile)))
253
254 (defun write-zipentry (z name data)
255 (setf name (substitute #\/ #\\ name))
256 (let* (#+allegro (excl:*locale* (excl:find-locale :latin1))
257 (s (zipwriter-stream z))
258 (header (make-local-header))
259 (utf8-name (string-to-octets name (zipwriter-external-format z)))
260 (entry (make-zipwriter-entry
261 :name name
262 :position (file-position s)
263 :header header)))
264 (setf (file/signature header) #x04034b50)
265 (setf (file/version-needed-to-extract header) 2) ;XXX ist das 2.0?
266 (setf (file/flags header) 8) ;bit 3: descriptor folgt nach daten
267 (setf (file/method header) 8)
268 (setf (file/time header) 0) ;XXX fixme
269 (setf (file/date header) 0) ;XXX fixme
270 (setf (file/crc header) 0)
271 (setf (file/compressed-size header) 0)
272 (setf (file/size header) 0)
273 (setf (file/name-length header) (length utf8-name))
274 (setf (file/extra-length header) 0)
275 (setf (zipwriter-tail z)
276 (setf (cdr (zipwriter-tail z)) (cons entry nil)))
277 (write-sequence header s)
278 (write-sequence utf8-name s)
279 (let ((descriptor (make-data-descriptor)))
280 (multiple-value-bind (nin nout crc)
281 (compress data s)
282 (setf (data/crc descriptor) crc)
283 (setf (data/compressed-size descriptor) nout)
284 (setf (data/size descriptor) nin)
285 ;; record same values for central directory
286 (setf (file/crc header) crc)
287 (setf (file/compressed-size header) nout)
288 (setf (file/size header) nin))
289 (write-sequence descriptor s))
290 name))
291
292 (defun write-central-directory (z)
293 (let* (#+allegro (excl:*locale* (excl:find-locale :latin1))
294 (s (zipwriter-stream z))
295 (pos (file-position s))
296 (n 0))
297 (dolist (e (cdr (zipwriter-head z)))
298 (incf n)
299 (let ((header (zipwriter-entry-header e))
300 (entry (make-directory-entry)))
301 (setf (cd/signature entry) #x02014b50)
302 (setf (cd/version-made-by entry) 0) ;dos compatible
303 (setf (cd/version-needed-to-extract entry)
304 (file/version-needed-to-extract header))
305 (setf (cd/flags entry) (file/flags header))
306 (setf (cd/method entry) (file/method header))
307 (setf (cd/time entry) (file/time header))
308 (setf (cd/date entry) (file/date header))
309 (setf (cd/crc entry) (file/crc header))
310 (setf (cd/compressed-size entry) (file/compressed-size header))
311 (setf (cd/size entry) (file/size header))
312 (setf (cd/name-length entry) (file/name-length header))
313 (setf (cd/extra-length entry) (file/extra-length header))
314 (setf (cd/comment-length entry) 0)
315 (setf (cd/disc-number entry) 0) ;XXX ?
316 (setf (cd/internal-attributes entry) 0)
317 (setf (cd/external-attributes entry) 0) ;XXX directories
318 (setf (cd/offset entry) (zipwriter-entry-position e))
319 (write-sequence entry s)
320 (write-sequence
321 (string-to-octets (zipwriter-entry-name e)
322 (zipwriter-external-format z))
323 s)))
324 (let ((end (make-end-header)))
325 (setf (end/signature end) #x06054b50)
326 (setf (end/this-disc end) 0) ;?
327 (setf (end/central-directory-disc end) 0) ;?
328 (setf (end/disc-files end) n)
329 (setf (end/total-files end) n)
330 (setf (end/central-directory-size end) (- (file-position s) pos))
331 (setf (end/central-directory-offset end) pos)
332 (setf (end/comment-length end) 0)
333 (write-sequence end s))))
334
335 (defmethod zipfile-entry-contents ((entry zipfile-entry) &optional stream)
336 (let (#+allegro (excl:*locale* (excl:find-locale :latin1))
337 (s (zipfile-entry-stream entry))
338 header)
339 (file-position s (zipfile-entry-offset entry))
340 (setf header (make-local-header s))
341 (assert (= (file/signature header) #x04034b50))
342 (file-position s (+ (file-position s)
343 (file/name-length header)
344 (file/extra-length header)))
345 (let ((in (make-instance 'truncating-stream
346 :input-handle s
347 :size (zipfile-entry-compressed-size entry)))
348 (outbuf nil)
349 out)
350 (if stream
351 (setf out stream)
352 (setf outbuf (make-byte-array (zipfile-entry-size entry))
353 out (make-buffer-output-stream outbuf)))
354 (ecase (file/method header)
355 (0 (store in out))
356 (8 (inflate in out)))
357 outbuf)))
358
359 (defmacro with-zipfile ((file pathname &key external-format) &body body)
360 `(let ((,file (open-zipfile ,pathname
361 ,@(when external-format
362 `(:external-format ,external-format)))))
363 (unwind-protect
364 (progn ,@body)
365 (close-zipfile ,file))))
366
367 (defun make-zipfile-writer
368 (pathname &key (if-exists :error)
369 (external-format
370 #+allegro (excl:find-external-format :default)
371 #-allegro :dummy))
372 (let (#+allegro (excl:*locale* (excl:find-locale :latin1))
373 (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 (when (or (pathname-name target-directory)
405 (pathname-type target-directory))
406 (error "pathname not a directory, lacks trailing slash?"))
407 (with-zipfile (zip pathname)
408 (do-zipfile-entries (name entry zip)
409 (let ((filename (merge-pathnames name target-directory)))
410 (ensure-directories-exist filename)
411 (unless (char= (elt name (1- (length name))) #\/)
412 (ecase verbose
413 ((nil))
414 ((t) (write-string name) (terpri))
415 (:dots (write-char #\.)))
416 (force-output)
417 (with-open-file
418 (s filename :direction :output :if-exists if-exists
419 :element-type '(unsigned-byte 8))
420 (zipfile-entry-contents entry s)))))))
421
422 (defun directoryp (pathname)
423 #+allegro (excl:file-directory-p pathname)
424 #-allegro (and (null (pathname-name pathname))
425 (null (pathname-type pathname))))
426
427 (defun zip (pathname source-directory &key (if-exists :error))
428 (with-output-to-zipfile (zip pathname :if-exists if-exists)
429 (labels ((recurse (d)
430 (dolist (f #+allegro (directory d :directories-are-files nil)
431 #-allegro (directory d))
432 (cond
433 ((directoryp f)
434 (write-zipentry
435 zip
436 (enough-namestring (namestring f) source-directory)
437 (make-concatenated-stream))
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) source-directory)
448 s)))))))
449 (recurse source-directory))))

  ViewVC Help
Powered by ViewVC 1.1.5