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

Contents of /zip/zip.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (hide 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 dlichteblau 1.7 ;;;; Copyright (c) 2004-2006 David Lichteblau <david@lichteblau.com>
2 dlichteblau 1.1 ;;;; Lizenz: (L)LGPL
3     ;;;;
4     ;;;; Urspruenglicher Autor: David Lichteblau.
5     ;;;; Aenderungen durch knowledgeTools GmbH.
6    
7 dlichteblau 1.7 ;;;; http://www.pkware.com/business_and_developers/developer/popups/appnote.txt
8     ;;;; (http://www.pkware.com/company/standards/appnote/)
9 dlichteblau 1.1
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 dlichteblau 1.8 (defmacro define-record (constructor
42     (&key (length #-clisp (gensym) #+clisp (gentemp)))
43     &rest fields)
44 dlichteblau 1.1 `(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 dlichteblau 1.11 (defun compress (input output compressor)
113 dlichteblau 1.1 (let ((nin 0)
114     (nout 0)
115 dlichteblau 1.11 (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 dlichteblau 1.1 (loop
122     (let ((end (read-sequence input-buffer input)))
123 dlichteblau 1.3 (cond
124     ((plusp end)
125 dlichteblau 1.11 (salza2:compress-octet-vector input-buffer compressor :end end)
126 dlichteblau 1.3 (incf nin end)
127 dlichteblau 1.11 (salza2:update crc input-buffer 0 end))
128 dlichteblau 1.3 (t
129 dlichteblau 1.11 (salza2:finish-compression compressor)
130     (salza2:reset compressor)
131     (return (values nin nout (salza2:result crc)))))))))))
132 dlichteblau 1.1
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 dlichteblau 1.11 (crc (make-instance 'salza2:crc32-checksum)))
140 dlichteblau 1.1 (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 dlichteblau 1.11 (salza2:update crc buf 0 n))
147     (values ntotal ntotal (salza2:result crc))))
148 dlichteblau 1.1
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 dlichteblau 1.8 compressed-size
171     comment)
172 dlichteblau 1.1
173     (defstruct zipwriter
174     stream
175 dlichteblau 1.11 compressor
176 dlichteblau 1.1 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 dlichteblau 1.8 :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 dlichteblau 1.1 (assert (= (cd/signature header) #x02014b50))
194     (read-sequence name s)
195     (setf name (octets-to-string name external-format))
196 dlichteblau 1.8 (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 dlichteblau 1.1
207     (defun open-zipfile
208 dlichteblau 1.4 (pathname &key (external-format (default-external-format)))
209 dlichteblau 1.7 (let* ((s (open pathname
210 dlichteblau 1.5 #-allegro :element-type
211     #-allegro '(unsigned-byte 8))))
212 dlichteblau 1.1 (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 dlichteblau 1.6 (defun write-zipentry
242     (z name data &key (file-write-date (file-write-date data)))
243 dlichteblau 1.1 (setf name (substitute #\/ #\\ name))
244 dlichteblau 1.7 (let* ((s (zipwriter-stream z))
245 dlichteblau 1.1 (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 dlichteblau 1.6 (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 dlichteblau 1.1 (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 dlichteblau 1.11 (compress data s (zipwriter-compressor z))
273 dlichteblau 1.1 (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 dlichteblau 1.7 (let* ((s (zipwriter-stream z))
285 dlichteblau 1.1 (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 dlichteblau 1.5 (setf (cd/version-made-by entry) 20) ;version 2.0, fat
293 dlichteblau 1.1 (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 dlichteblau 1.7 (let ((s (zipfile-entry-stream entry))
327 dlichteblau 1.1 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 dlichteblau 1.4 (external-format (default-external-format)))
359 dlichteblau 1.7 (let ((c (cons nil nil)))
360 dlichteblau 1.1 (make-zipwriter
361     :stream (open pathname
362     :direction :output
363     :if-exists if-exists
364     :element-type '(unsigned-byte 8))
365 dlichteblau 1.11 :compressor (make-instance 'salza2:deflate-compressor)
366 dlichteblau 1.1 :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 dlichteblau 1.10 ;; <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 dlichteblau 1.1 (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 dlichteblau 1.9 (defun %directoryp (pathname)
413 dlichteblau 1.1 #+allegro (excl:file-directory-p pathname)
414 dlichteblau 1.4 #+lispworks (lispworks:file-directory-p pathname)
415 dlichteblau 1.9 #+clisp (ignore-errors
416     (ext:probe-directory
417     (concatenate 'string (princ-to-string pathname) "/")))
418     #-(or lispworks allegro clisp)
419 dlichteblau 1.4 (and (null (pathname-name pathname))
420     (null (pathname-type pathname))))
421 dlichteblau 1.1
422 dlichteblau 1.9 (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 dlichteblau 1.1 (defun zip (pathname source-directory &key (if-exists :error))
442 dlichteblau 1.9 (let ((base (%directory-namestring (merge-pathnames source-directory))))
443 dlichteblau 1.4 (with-output-to-zipfile (zip pathname :if-exists if-exists)
444     (labels ((recurse (d)
445 dlichteblau 1.9 (dolist (f (%directory d))
446 dlichteblau 1.4 (cond
447 dlichteblau 1.9 ((%directoryp f)
448 dlichteblau 1.1 (write-zipentry
449     zip
450 dlichteblau 1.4 (enough-namestring (namestring f) base)
451 dlichteblau 1.6 (make-concatenated-stream)
452 dlichteblau 1.9 :file-write-date (%file-write-date f))
453     (recurse (%pathname-for-directory f)))
454 dlichteblau 1.4 ((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