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

Contents of /zip/zip.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5