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

Contents of /zip/zip.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5