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

Contents of /zip/zip.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.9 - (hide annotations)
Sat Jun 10 14:07:53 2006 UTC (7 years, 10 months ago) by dlichteblau
Branch: MAIN
Changes since 1.8: +29 -12 lines
CLISP workarounds (Klaus Weidner)
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     (defun update-crc (crc buf &optional (end (length buf)))
113     (multiple-value-bind (high low)
114     (salza-deflate:crc32 (logxor (ldb (byte 16 16) crc) #xffff)
115     (logxor (ldb (byte 16 00) crc) #xffff)
116     buf
117     end)
118     (logior (ash (logxor high #xffff) 16) (logxor low #xffff))))
119    
120     (defun compress (input output)
121     (let ((nin 0)
122     (nout 0)
123     (crc 0))
124     (flet ((flush-stream (zlib-stream)
125     (let ((start (if (zerop nout) 2 0))
126 dlichteblau 1.2 (end (salza:zlib-stream-position zlib-stream)))
127 dlichteblau 1.1 (write-sequence (salza::zlib-stream-buffer zlib-stream)
128     output
129     :start start
130     :end end)
131     (incf nout (- end start))
132 dlichteblau 1.2 (setf (salza:zlib-stream-position zlib-stream) 0))))
133 dlichteblau 1.1 (let* ((input-buffer (make-array 8192 :element-type '(unsigned-byte 8)))
134     (output-buffer (make-array 8192 :element-type '(unsigned-byte 8)))
135     (zlib-stream (salza:make-zlib-stream output-buffer
136     :callback #'flush-stream)))
137     (loop
138     (let ((end (read-sequence input-buffer input)))
139 dlichteblau 1.3 (cond
140     ((plusp end)
141     (salza:zlib-write-sequence input-buffer zlib-stream :end end)
142     (incf nin end)
143     (setf crc (update-crc crc input-buffer end)))
144     (t
145     (salza:finish-zlib-stream zlib-stream)
146     (return (values nin nout crc))))))))))
147 dlichteblau 1.1
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     (loop
156     for n = (read-sequence buf in :end (length buf))
157     until (zerop n)
158     do
159     (write-sequence buf out :end n)
160     (incf ntotal n)
161 dlichteblau 1.2 (setf crc (update-crc crc buf n)))
162 dlichteblau 1.1 (values ntotal ntotal crc)))
163    
164     (defun seek-to-end-header (s)
165     (let* ((len (+ 65536 +end-header-length+))
166     (guess (max 0 (- (file-length s) len))))
167     (file-position s guess)
168     (let ((v (make-byte-array (min (file-length s) len))))
169     (read-sequence v s)
170     (let ((n (search #(80 75 5 6) v :from-end t)))
171     (unless n
172     (error "end of central directory header not found"))
173     (file-position s (+ guess n))))))
174    
175     (defstruct zipfile
176     stream
177     entries
178     external-format)
179    
180     (defstruct zipfile-entry
181     name
182     stream
183     offset
184     size
185 dlichteblau 1.8 compressed-size
186     comment)
187 dlichteblau 1.1
188     (defstruct zipwriter
189     stream
190     head
191     tail
192     external-format)
193    
194     (defstruct zipwriter-entry
195     name
196     position
197     header)
198    
199     (defun read-entry-object (s external-format)
200     (let* ((header (make-directory-entry s))
201     (name (make-array (cd/name-length header)
202 dlichteblau 1.8 :element-type '(unsigned-byte 8)))
203     (comment
204     (when (plusp (cd/comment-length header))
205     (make-array (cd/comment-length header)
206     :element-type '(unsigned-byte 8)))))
207 dlichteblau 1.1 (assert (= (cd/signature header) #x02014b50))
208     (read-sequence name s)
209     (setf name (octets-to-string name external-format))
210 dlichteblau 1.8 (file-position s (+ (file-position s) (cd/extra-length header)))
211     (when comment
212     (read-sequence comment s)
213     (setf comment (octets-to-string comment external-format)))
214     (make-zipfile-entry :name name
215     :stream s
216     :offset (cd/offset header)
217     :size (cd/size header)
218     :compressed-size (cd/compressed-size header)
219     :comment comment)))
220 dlichteblau 1.1
221     (defun open-zipfile
222 dlichteblau 1.4 (pathname &key (external-format (default-external-format)))
223 dlichteblau 1.7 (let* ((s (open pathname
224 dlichteblau 1.5 #-allegro :element-type
225     #-allegro '(unsigned-byte 8))))
226 dlichteblau 1.1 (unwind-protect
227     (progn
228     (seek-to-end-header s)
229     (let* ((end (make-end-header s))
230     (n (end/total-files end))
231     (entries (make-hash-table :test #'equal))
232     (zipfile (make-zipfile :stream s
233     :entries entries
234     :external-format external-format)))
235     (file-position s (end/central-directory-offset end))
236     (dotimes (x n)
237     (let ((entry (read-entry-object s external-format)))
238     (setf (gethash (zipfile-entry-name entry) entries) entry)))
239     #+sbcl (let ((s s)) (sb-ext:finalize zipfile (lambda ()(close s))))
240     (setf s nil)
241     zipfile))
242     (when s
243     (close s)))))
244    
245     (defgeneric close-zipfile (zipfile))
246     (defgeneric get-zipfile-entry (name zipfile))
247     (defgeneric zipfile-entry-contents (entry &optional stream))
248    
249     (defmethod close-zipfile ((zipfile zipfile))
250     (close (zipfile-stream zipfile)))
251    
252     (defmethod get-zipfile-entry (name (zipfile zipfile))
253     (gethash name (zipfile-entries zipfile)))
254    
255 dlichteblau 1.6 (defun write-zipentry
256     (z name data &key (file-write-date (file-write-date data)))
257 dlichteblau 1.1 (setf name (substitute #\/ #\\ name))
258 dlichteblau 1.7 (let* ((s (zipwriter-stream z))
259 dlichteblau 1.1 (header (make-local-header))
260     (utf8-name (string-to-octets name (zipwriter-external-format z)))
261     (entry (make-zipwriter-entry
262     :name name
263     :position (file-position s)
264     :header header)))
265     (setf (file/signature header) #x04034b50)
266     (setf (file/version-needed-to-extract header) 2) ;XXX ist das 2.0?
267     (setf (file/flags header) 8) ;bit 3: descriptor folgt nach daten
268     (setf (file/method header) 8)
269 dlichteblau 1.6 (multiple-value-bind (s min h d m y)
270     (decode-universal-time
271     (or file-write-date (encode-universal-time 0 0 0 1 1 1980 0)))
272     (setf (file/time header)
273     (logior (ash h 11) (ash min 5) (ash s -1)))
274     (setf (file/date header)
275     (logior (ash (- y 1980) 9) (ash m 5) d)))
276 dlichteblau 1.1 (setf (file/compressed-size header) 0)
277     (setf (file/size header) 0)
278     (setf (file/name-length header) (length utf8-name))
279     (setf (file/extra-length header) 0)
280     (setf (zipwriter-tail z)
281     (setf (cdr (zipwriter-tail z)) (cons entry nil)))
282     (write-sequence header s)
283     (write-sequence utf8-name s)
284     (let ((descriptor (make-data-descriptor)))
285     (multiple-value-bind (nin nout crc)
286     (compress data s)
287     (setf (data/crc descriptor) crc)
288     (setf (data/compressed-size descriptor) nout)
289     (setf (data/size descriptor) nin)
290     ;; record same values for central directory
291     (setf (file/crc header) crc)
292     (setf (file/compressed-size header) nout)
293     (setf (file/size header) nin))
294     (write-sequence descriptor s))
295     name))
296    
297     (defun write-central-directory (z)
298 dlichteblau 1.7 (let* ((s (zipwriter-stream z))
299 dlichteblau 1.1 (pos (file-position s))
300     (n 0))
301     (dolist (e (cdr (zipwriter-head z)))
302     (incf n)
303     (let ((header (zipwriter-entry-header e))
304     (entry (make-directory-entry)))
305     (setf (cd/signature entry) #x02014b50)
306 dlichteblau 1.5 (setf (cd/version-made-by entry) 20) ;version 2.0, fat
307 dlichteblau 1.1 (setf (cd/version-needed-to-extract entry)
308     (file/version-needed-to-extract header))
309     (setf (cd/flags entry) (file/flags header))
310     (setf (cd/method entry) (file/method header))
311     (setf (cd/time entry) (file/time header))
312     (setf (cd/date entry) (file/date header))
313     (setf (cd/crc entry) (file/crc header))
314     (setf (cd/compressed-size entry) (file/compressed-size header))
315     (setf (cd/size entry) (file/size header))
316     (setf (cd/name-length entry) (file/name-length header))
317     (setf (cd/extra-length entry) (file/extra-length header))
318     (setf (cd/comment-length entry) 0)
319     (setf (cd/disc-number entry) 0) ;XXX ?
320     (setf (cd/internal-attributes entry) 0)
321     (setf (cd/external-attributes entry) 0) ;XXX directories
322     (setf (cd/offset entry) (zipwriter-entry-position e))
323     (write-sequence entry s)
324     (write-sequence
325     (string-to-octets (zipwriter-entry-name e)
326     (zipwriter-external-format z))
327     s)))
328     (let ((end (make-end-header)))
329     (setf (end/signature end) #x06054b50)
330     (setf (end/this-disc end) 0) ;?
331     (setf (end/central-directory-disc end) 0) ;?
332     (setf (end/disc-files end) n)
333     (setf (end/total-files end) n)
334     (setf (end/central-directory-size end) (- (file-position s) pos))
335     (setf (end/central-directory-offset end) pos)
336     (setf (end/comment-length end) 0)
337     (write-sequence end s))))
338    
339     (defmethod zipfile-entry-contents ((entry zipfile-entry) &optional stream)
340 dlichteblau 1.7 (let ((s (zipfile-entry-stream entry))
341 dlichteblau 1.1 header)
342     (file-position s (zipfile-entry-offset entry))
343     (setf header (make-local-header s))
344     (assert (= (file/signature header) #x04034b50))
345     (file-position s (+ (file-position s)
346     (file/name-length header)
347     (file/extra-length header)))
348     (let ((in (make-instance 'truncating-stream
349     :input-handle s
350     :size (zipfile-entry-compressed-size entry)))
351     (outbuf nil)
352     out)
353     (if stream
354     (setf out stream)
355     (setf outbuf (make-byte-array (zipfile-entry-size entry))
356     out (make-buffer-output-stream outbuf)))
357     (ecase (file/method header)
358     (0 (store in out))
359     (8 (inflate in out)))
360     outbuf)))
361    
362     (defmacro with-zipfile ((file pathname &key external-format) &body body)
363     `(let ((,file (open-zipfile ,pathname
364     ,@(when external-format
365     `(:external-format ,external-format)))))
366     (unwind-protect
367     (progn ,@body)
368     (close-zipfile ,file))))
369    
370     (defun make-zipfile-writer
371     (pathname &key (if-exists :error)
372 dlichteblau 1.4 (external-format (default-external-format)))
373 dlichteblau 1.7 (let ((c (cons nil nil)))
374 dlichteblau 1.1 (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 dlichteblau 1.9 (defun %directoryp (pathname)
423 dlichteblau 1.1 #+allegro (excl:file-directory-p pathname)
424 dlichteblau 1.4 #+lispworks (lispworks:file-directory-p pathname)
425 dlichteblau 1.9 #+clisp (ignore-errors
426     (ext:probe-directory
427     (concatenate 'string (princ-to-string pathname) "/")))
428     #-(or lispworks allegro clisp)
429 dlichteblau 1.4 (and (null (pathname-name pathname))
430     (null (pathname-type pathname))))
431 dlichteblau 1.1
432 dlichteblau 1.9 (defun %directory (d)
433     #+allegro (directory d :directories-are-files nil)
434     #+clisp (append (directory (concatenate 'string (princ-to-string d) "/*/"))
435     (directory (concatenate 'string (princ-to-string d) "/*")))
436     #-(or allegro clisp) (directory d))
437    
438     (defun %file-write-date (f)
439     #+clisp (posix:file-stat-mtime (posix:file-stat f))
440     #-clisp (file-write-date f))
441    
442     (defun %pathname-for-directory (f)
443     #+(or allegro clisp) f
444     #-(or allegro clisp) (make-pathname :name :wild :type :wild :defaults f))
445    
446     (defun %directory-namestring (d)
447     #+clisp (directory-namestring
448     (truename (concatenate 'string (princ-to-string d) "/")))
449     #-clisp (directory-namestring d))
450    
451 dlichteblau 1.1 (defun zip (pathname source-directory &key (if-exists :error))
452 dlichteblau 1.9 (let ((base (%directory-namestring (merge-pathnames source-directory))))
453 dlichteblau 1.4 (with-output-to-zipfile (zip pathname :if-exists if-exists)
454     (labels ((recurse (d)
455 dlichteblau 1.9 (dolist (f (%directory d))
456 dlichteblau 1.4 (cond
457 dlichteblau 1.9 ((%directoryp f)
458 dlichteblau 1.1 (write-zipentry
459     zip
460 dlichteblau 1.4 (enough-namestring (namestring f) base)
461 dlichteblau 1.6 (make-concatenated-stream)
462 dlichteblau 1.9 :file-write-date (%file-write-date f))
463     (recurse (%pathname-for-directory f)))
464 dlichteblau 1.4 ((or (pathname-name f) (pathname-type f))
465     (with-open-file (s f :element-type '(unsigned-byte 8))
466     (write-zipentry
467     zip
468     (enough-namestring (namestring f) base)
469     s)))))))
470     (recurse source-directory)))))

  ViewVC Help
Powered by ViewVC 1.1.5