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

Contents of /zip/zip.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (hide annotations)
Sun Mar 19 14:01:09 2006 UTC (8 years, 1 month ago) by dlichteblau
Branch: MAIN
Changes since 1.6: +8 -12 lines
     <p>
+      2006-xx-yy: Fixed the gray stream port (including a data
+      corruption bug that was in CVS for some time).  Switched to
+      flexi-stream external-format functions for portability.  Uses
+      trivial-gray-streams now.  Allegro 8.0 fix.  Incompatible change:
+      Don't bind <tt>*locale*</tt> on Allegro anymore.  (Thanks to all
+      patch submitters).
+    <p>
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     (defmacro define-record (constructor (&key (length (gensym))) &rest fields)
42     `(progn
43     (defconstant ,length
44     ,(loop
45     for (nil type) in fields
46     sum (ecase type (:int 4) (:short 2))))
47     (defun ,constructor (&optional s)
48     (let ((bytes (make-byte-array ,length)))
49     (when s
50     (read-sequence bytes s))
51     bytes))
52     ,@(loop
53     for (name type) in fields
54     for offset = 0 then (+ offset length)
55     for length = (ecase type (:int 4) (:short 2))
56     for reader = (ecase type (:int 'get-int) (:short 'get-short))
57     unless (eq name :dummy)
58     append `((defun ,name (r)
59     (,reader r ,offset))
60     (defun (setf ,name) (newval r)
61     (setf (,reader r ,offset) newval))))))
62    
63     (define-record make-end-header (:length +end-header-length+)
64     (end/signature :int)
65     (end/this-disc :short)
66     (end/central-directory-disc :short)
67     (end/disc-files :short)
68     (end/total-files :short)
69     (end/central-directory-size :int)
70     (end/central-directory-offset :int)
71     (end/comment-length :short))
72    
73     (define-record make-directory-entry ()
74     (cd/signature :int)
75     (cd/version-made-by :short)
76     (cd/version-needed-to-extract :short)
77     (cd/flags :short)
78     (cd/method :short)
79     (cd/time :short)
80     (cd/date :short)
81     (cd/crc :int)
82     (cd/compressed-size :int)
83     (cd/size :int)
84     (cd/name-length :short)
85     (cd/extra-length :short)
86     (cd/comment-length :short)
87     (cd/disc-number :short)
88     (cd/internal-attributes :short)
89     (cd/external-attributes :int)
90     (cd/offset :int))
91    
92     (define-record make-local-header ()
93     (file/signature :int)
94     (file/version-needed-to-extract :short)
95     (file/flags :short)
96     (file/method :short)
97     (file/time :short)
98     (file/date :short)
99     (file/crc :int)
100     (file/compressed-size :int)
101     (file/size :int)
102     (file/name-length :short)
103     (file/extra-length :short))
104    
105     (define-record make-data-descriptor ()
106     (data/crc :int)
107     (data/compressed-size :int)
108     (data/size :int))
109    
110     (defun update-crc (crc buf &optional (end (length buf)))
111     (multiple-value-bind (high low)
112     (salza-deflate:crc32 (logxor (ldb (byte 16 16) crc) #xffff)
113     (logxor (ldb (byte 16 00) crc) #xffff)
114     buf
115     end)
116     (logior (ash (logxor high #xffff) 16) (logxor low #xffff))))
117    
118     (defun compress (input output)
119     (let ((nin 0)
120     (nout 0)
121     (crc 0))
122     (flet ((flush-stream (zlib-stream)
123     (let ((start (if (zerop nout) 2 0))
124 dlichteblau 1.2 (end (salza:zlib-stream-position zlib-stream)))
125 dlichteblau 1.1 (write-sequence (salza::zlib-stream-buffer zlib-stream)
126     output
127     :start start
128     :end end)
129     (incf nout (- end start))
130 dlichteblau 1.2 (setf (salza:zlib-stream-position zlib-stream) 0))))
131 dlichteblau 1.1 (let* ((input-buffer (make-array 8192 :element-type '(unsigned-byte 8)))
132     (output-buffer (make-array 8192 :element-type '(unsigned-byte 8)))
133     (zlib-stream (salza:make-zlib-stream output-buffer
134     :callback #'flush-stream)))
135     (loop
136     (let ((end (read-sequence input-buffer input)))
137 dlichteblau 1.3 (cond
138     ((plusp end)
139     (salza:zlib-write-sequence input-buffer zlib-stream :end end)
140     (incf nin end)
141     (setf crc (update-crc crc input-buffer end)))
142     (t
143     (salza:finish-zlib-stream zlib-stream)
144     (return (values nin nout crc))))))))))
145 dlichteblau 1.1
146     (defun store (in out)
147     "Copy uncompressed bytes from IN to OUT and return values like COMPRESS."
148     (let ((buf (make-array 8192
149     :initial-element 0
150     :element-type '(unsigned-byte 8)))
151     (ntotal 0)
152     (crc 0))
153     (loop
154     for n = (read-sequence buf in :end (length buf))
155     until (zerop n)
156     do
157     (write-sequence buf out :end n)
158     (incf ntotal n)
159 dlichteblau 1.2 (setf crc (update-crc crc buf n)))
160 dlichteblau 1.1 (values ntotal ntotal crc)))
161    
162     (defun seek-to-end-header (s)
163     (let* ((len (+ 65536 +end-header-length+))
164     (guess (max 0 (- (file-length s) len))))
165     (file-position s guess)
166     (let ((v (make-byte-array (min (file-length s) len))))
167     (read-sequence v s)
168     (let ((n (search #(80 75 5 6) v :from-end t)))
169     (unless n
170     (error "end of central directory header not found"))
171     (file-position s (+ guess n))))))
172    
173     (defstruct zipfile
174     stream
175     entries
176     external-format)
177    
178     (defstruct zipfile-entry
179     name
180     stream
181     offset
182     size
183     compressed-size)
184    
185     (defstruct zipwriter
186     stream
187     head
188     tail
189     external-format)
190    
191     (defstruct zipwriter-entry
192     name
193     position
194     header)
195    
196     (defun read-entry-object (s external-format)
197     (let* ((header (make-directory-entry s))
198     (name (make-array (cd/name-length header)
199     :element-type '(unsigned-byte 8))))
200     (assert (= (cd/signature header) #x02014b50))
201     (read-sequence name s)
202     (setf name (octets-to-string name external-format))
203     (prog1
204     (make-zipfile-entry :name name
205     :stream s
206     :offset (cd/offset header)
207     :size (cd/size header)
208     :compressed-size (cd/compressed-size header))
209     (file-position s (+ (file-position s)
210     (cd/extra-length header)
211     (cd/comment-length header))))))
212    
213     (defun open-zipfile
214 dlichteblau 1.4 (pathname &key (external-format (default-external-format)))
215 dlichteblau 1.7 (let* ((s (open pathname
216 dlichteblau 1.5 #-allegro :element-type
217     #-allegro '(unsigned-byte 8))))
218 dlichteblau 1.1 (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 dlichteblau 1.6 (defun write-zipentry
248     (z name data &key (file-write-date (file-write-date data)))
249 dlichteblau 1.1 (setf name (substitute #\/ #\\ name))
250 dlichteblau 1.7 (let* ((s (zipwriter-stream z))
251 dlichteblau 1.1 (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 dlichteblau 1.6 (multiple-value-bind (s min h d m y)
262     (decode-universal-time
263     (or file-write-date (encode-universal-time 0 0 0 1 1 1980 0)))
264     (setf (file/time header)
265     (logior (ash h 11) (ash min 5) (ash s -1)))
266     (setf (file/date header)
267     (logior (ash (- y 1980) 9) (ash m 5) d)))
268 dlichteblau 1.1 (setf (file/compressed-size header) 0)
269     (setf (file/size header) 0)
270     (setf (file/name-length header) (length utf8-name))
271     (setf (file/extra-length header) 0)
272     (setf (zipwriter-tail z)
273     (setf (cdr (zipwriter-tail z)) (cons entry nil)))
274     (write-sequence header s)
275     (write-sequence utf8-name s)
276     (let ((descriptor (make-data-descriptor)))
277     (multiple-value-bind (nin nout crc)
278     (compress data s)
279     (setf (data/crc descriptor) crc)
280     (setf (data/compressed-size descriptor) nout)
281     (setf (data/size descriptor) nin)
282     ;; record same values for central directory
283     (setf (file/crc header) crc)
284     (setf (file/compressed-size header) nout)
285     (setf (file/size header) nin))
286     (write-sequence descriptor s))
287     name))
288    
289     (defun write-central-directory (z)
290 dlichteblau 1.7 (let* ((s (zipwriter-stream z))
291 dlichteblau 1.1 (pos (file-position s))
292     (n 0))
293     (dolist (e (cdr (zipwriter-head z)))
294     (incf n)
295     (let ((header (zipwriter-entry-header e))
296     (entry (make-directory-entry)))
297     (setf (cd/signature entry) #x02014b50)
298 dlichteblau 1.5 (setf (cd/version-made-by entry) 20) ;version 2.0, fat
299 dlichteblau 1.1 (setf (cd/version-needed-to-extract entry)
300     (file/version-needed-to-extract header))
301     (setf (cd/flags entry) (file/flags header))
302     (setf (cd/method entry) (file/method header))
303     (setf (cd/time entry) (file/time header))
304     (setf (cd/date entry) (file/date header))
305     (setf (cd/crc entry) (file/crc header))
306     (setf (cd/compressed-size entry) (file/compressed-size header))
307     (setf (cd/size entry) (file/size header))
308     (setf (cd/name-length entry) (file/name-length header))
309     (setf (cd/extra-length entry) (file/extra-length header))
310     (setf (cd/comment-length entry) 0)
311     (setf (cd/disc-number entry) 0) ;XXX ?
312     (setf (cd/internal-attributes entry) 0)
313     (setf (cd/external-attributes entry) 0) ;XXX directories
314     (setf (cd/offset entry) (zipwriter-entry-position e))
315     (write-sequence entry s)
316     (write-sequence
317     (string-to-octets (zipwriter-entry-name e)
318     (zipwriter-external-format z))
319     s)))
320     (let ((end (make-end-header)))
321     (setf (end/signature end) #x06054b50)
322     (setf (end/this-disc end) 0) ;?
323     (setf (end/central-directory-disc end) 0) ;?
324     (setf (end/disc-files end) n)
325     (setf (end/total-files end) n)
326     (setf (end/central-directory-size end) (- (file-position s) pos))
327     (setf (end/central-directory-offset end) pos)
328     (setf (end/comment-length end) 0)
329     (write-sequence end s))))
330    
331     (defmethod zipfile-entry-contents ((entry zipfile-entry) &optional stream)
332 dlichteblau 1.7 (let ((s (zipfile-entry-stream entry))
333 dlichteblau 1.1 header)
334     (file-position s (zipfile-entry-offset entry))
335     (setf header (make-local-header s))
336     (assert (= (file/signature header) #x04034b50))
337     (file-position s (+ (file-position s)
338     (file/name-length header)
339     (file/extra-length header)))
340     (let ((in (make-instance 'truncating-stream
341     :input-handle s
342     :size (zipfile-entry-compressed-size entry)))
343     (outbuf nil)
344     out)
345     (if stream
346     (setf out stream)
347     (setf outbuf (make-byte-array (zipfile-entry-size entry))
348     out (make-buffer-output-stream outbuf)))
349     (ecase (file/method header)
350     (0 (store in out))
351     (8 (inflate in out)))
352     outbuf)))
353    
354     (defmacro with-zipfile ((file pathname &key external-format) &body body)
355     `(let ((,file (open-zipfile ,pathname
356     ,@(when external-format
357     `(:external-format ,external-format)))))
358     (unwind-protect
359     (progn ,@body)
360     (close-zipfile ,file))))
361    
362     (defun make-zipfile-writer
363     (pathname &key (if-exists :error)
364 dlichteblau 1.4 (external-format (default-external-format)))
365 dlichteblau 1.7 (let ((c (cons nil nil)))
366 dlichteblau 1.1 (make-zipwriter
367     :stream (open pathname
368     :direction :output
369     :if-exists if-exists
370     :element-type '(unsigned-byte 8))
371     :external-format external-format
372     :head c
373     :tail c)))
374    
375     (defun close-zipfile-writer (z)
376     (write-central-directory z)
377     (close (zipwriter-stream z)))
378    
379     (defmacro with-output-to-zipfile
380     ((var pathname &key (if-exists :error)) &body body)
381     `(let ((,var (make-zipfile-writer ,pathname :if-exists ,if-exists)))
382     (unwind-protect
383     (progn ,@body)
384     (close-zipfile-writer ,var))))
385    
386     (defmacro do-zipfile-entries ((name entry zipfile) &body body)
387     (setf name (or name (gensym)))
388     (setf entry (or entry (gensym)))
389     `(block nil
390     (maphash (lambda (,name ,entry)
391     (declare (ignorable ,name ,entry))
392     ,@body)
393     (zipfile-entries ,zipfile))))
394    
395     (defun unzip (pathname target-directory &key (if-exists :error) verbose)
396     (when (or (pathname-name target-directory)
397     (pathname-type target-directory))
398     (error "pathname not a directory, lacks trailing slash?"))
399     (with-zipfile (zip pathname)
400     (do-zipfile-entries (name entry zip)
401     (let ((filename (merge-pathnames name target-directory)))
402     (ensure-directories-exist filename)
403     (unless (char= (elt name (1- (length name))) #\/)
404     (ecase verbose
405     ((nil))
406     ((t) (write-string name) (terpri))
407     (:dots (write-char #\.)))
408     (force-output)
409     (with-open-file
410     (s filename :direction :output :if-exists if-exists
411     :element-type '(unsigned-byte 8))
412     (zipfile-entry-contents entry s)))))))
413    
414     (defun directoryp (pathname)
415     #+allegro (excl:file-directory-p pathname)
416 dlichteblau 1.4 #+lispworks (lispworks:file-directory-p pathname)
417     #-(or lispworks allegro)
418     (and (null (pathname-name pathname))
419     (null (pathname-type pathname))))
420 dlichteblau 1.1
421     (defun zip (pathname source-directory &key (if-exists :error))
422 dlichteblau 1.4 (let ((base (directory-namestring source-directory)))
423     (with-output-to-zipfile (zip pathname :if-exists if-exists)
424     (labels ((recurse (d)
425     (dolist (f #+allegro (directory d :directories-are-files nil)
426     #-allegro (directory d))
427     (cond
428     ((directoryp f)
429 dlichteblau 1.1 (write-zipentry
430     zip
431 dlichteblau 1.4 (enough-namestring (namestring f) base)
432 dlichteblau 1.6 (make-concatenated-stream)
433     :file-write-date (file-write-date f))
434 dlichteblau 1.4 (recurse #+allegro f
435     #-allegro (make-pathname
436     :name :wild
437     :type :wild
438     :defaults f)))
439     ((or (pathname-name f) (pathname-type f))
440     (with-open-file (s f :element-type '(unsigned-byte 8))
441     (write-zipentry
442     zip
443     (enough-namestring (namestring f) base)
444     s)))))))
445     (recurse source-directory)))))

  ViewVC Help
Powered by ViewVC 1.1.5