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

Contents of /zip/zip.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.1.1 - (hide annotations) (vendor branch)
Sun Apr 3 19:36:28 2005 UTC (9 years ago) by dlichteblau
Branch: dlichteblau
CVS Tags: start
Changes since 1.1: +0 -0 lines
initial import
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     (end (salza::zlib-stream-position zlib-stream)))
124     (write-sequence (salza::zlib-stream-buffer zlib-stream)
125     output
126     :start start
127     :end end)
128     (incf nout (- end start))
129     (setf (salza::zlib-stream-position zlib-stream) 0))))
130     (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     (salza:zlib-write-sequence input-buffer zlib-stream :end end)
137     (incf nin end)
138     (let
139     ;; fixme
140     ((b (if (eql end (length input-buffer))
141     input-buffer
142     (subseq input-buffer 0 end))))
143     (setf crc (update-crc crc b)))
144     (when (zerop end)
145     (salza:finish-zlib-stream zlib-stream)
146     (return (values nin nout crc)))))))))
147    
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     ;; Compute CRC using R. Matthew Emerson's Lisp implementation instead of
156     ;; zlib's CRC function, since STORE is (only) useful in the absence of
157     ;; zlib anyway.
158     (loop
159     for n = (read-sequence buf in :end (length buf))
160     until (zerop n)
161     do
162     (write-sequence buf out :end n)
163     (incf ntotal n)
164     (let ((b (if (eql n (length buf)) buf (subseq buf 0 n))))
165     (setf crc (update-crc crc b))))
166     (values ntotal ntotal crc)))
167    
168     (defun seek-to-end-header (s)
169     (let* ((len (+ 65536 +end-header-length+))
170     (guess (max 0 (- (file-length s) len))))
171     (file-position s guess)
172     (let ((v (make-byte-array (min (file-length s) len))))
173     (read-sequence v s)
174     (let ((n (search #(80 75 5 6) v :from-end t)))
175     (unless n
176     (error "end of central directory header not found"))
177     (file-position s (+ guess n))))))
178    
179     (defstruct zipfile
180     stream
181     entries
182     external-format)
183    
184     (defstruct zipfile-entry
185     name
186     stream
187     offset
188     size
189     compressed-size)
190    
191     (defstruct zipwriter
192     stream
193     head
194     tail
195     external-format)
196    
197     (defstruct zipwriter-entry
198     name
199     position
200     header)
201    
202     (defun read-entry-object (s external-format)
203     (let* ((header (make-directory-entry s))
204     (name (make-array (cd/name-length header)
205     :element-type '(unsigned-byte 8))))
206     (assert (= (cd/signature header) #x02014b50))
207     (read-sequence name s)
208     (setf name (octets-to-string name external-format))
209     (prog1
210     (make-zipfile-entry :name name
211     :stream s
212     :offset (cd/offset header)
213     :size (cd/size header)
214     :compressed-size (cd/compressed-size header))
215     (file-position s (+ (file-position s)
216     (cd/extra-length header)
217     (cd/comment-length header))))))
218    
219     (defun open-zipfile
220     (pathname &key (external-format
221     #+allegro (excl:find-external-format :default)
222     #-allegro :dummy))
223     (let* (#+allegro (excl:*locale* (excl:find-locale :latin1))
224     (s (open pathname :element-type '(unsigned-byte 8))))
225     (unwind-protect
226     (progn
227     (seek-to-end-header s)
228     (let* ((end (make-end-header s))
229     (n (end/total-files end))
230     (entries (make-hash-table :test #'equal))
231     (zipfile (make-zipfile :stream s
232     :entries entries
233     :external-format external-format)))
234     (file-position s (end/central-directory-offset end))
235     (dotimes (x n)
236     (let ((entry (read-entry-object s external-format)))
237     (setf (gethash (zipfile-entry-name entry) entries) entry)))
238     #+sbcl (let ((s s)) (sb-ext:finalize zipfile (lambda ()(close s))))
239     (setf s nil)
240     zipfile))
241     (when s
242     (close s)))))
243    
244     (defgeneric close-zipfile (zipfile))
245     (defgeneric get-zipfile-entry (name zipfile))
246     (defgeneric zipfile-entry-contents (entry &optional stream))
247    
248     (defmethod close-zipfile ((zipfile zipfile))
249     (close (zipfile-stream zipfile)))
250    
251     (defmethod get-zipfile-entry (name (zipfile zipfile))
252     (gethash name (zipfile-entries zipfile)))
253    
254     (defun write-zipentry (z name data)
255     (setf name (substitute #\/ #\\ name))
256     (let* (#+allegro (excl:*locale* (excl:find-locale :latin1))
257     (s (zipwriter-stream z))
258     (header (make-local-header))
259     (utf8-name (string-to-octets name (zipwriter-external-format z)))
260     (entry (make-zipwriter-entry
261     :name name
262     :position (file-position s)
263     :header header)))
264     (setf (file/signature header) #x04034b50)
265     (setf (file/version-needed-to-extract header) 2) ;XXX ist das 2.0?
266     (setf (file/flags header) 8) ;bit 3: descriptor folgt nach daten
267     (setf (file/method header) 8)
268     (setf (file/time header) 0) ;XXX fixme
269     (setf (file/date header) 0) ;XXX fixme
270     (setf (file/crc header) 0)
271     (setf (file/compressed-size header) 0)
272     (setf (file/size header) 0)
273     (setf (file/name-length header) (length utf8-name))
274     (setf (file/extra-length header) 0)
275     (setf (zipwriter-tail z)
276     (setf (cdr (zipwriter-tail z)) (cons entry nil)))
277     (write-sequence header s)
278     (write-sequence utf8-name s)
279     (let ((descriptor (make-data-descriptor)))
280     (multiple-value-bind (nin nout crc)
281     (compress data s)
282     (setf (data/crc descriptor) crc)
283     (setf (data/compressed-size descriptor) nout)
284     (setf (data/size descriptor) nin)
285     ;; record same values for central directory
286     (setf (file/crc header) crc)
287     (setf (file/compressed-size header) nout)
288     (setf (file/size header) nin))
289     (write-sequence descriptor s))
290     name))
291    
292     (defun write-central-directory (z)
293     (let* (#+allegro (excl:*locale* (excl:find-locale :latin1))
294     (s (zipwriter-stream z))
295     (pos (file-position s))
296     (n 0))
297     (dolist (e (cdr (zipwriter-head z)))
298     (incf n)
299     (let ((header (zipwriter-entry-header e))
300     (entry (make-directory-entry)))
301     (setf (cd/signature entry) #x02014b50)
302     (setf (cd/version-made-by entry) 0) ;dos compatible
303     (setf (cd/version-needed-to-extract entry)
304     (file/version-needed-to-extract header))
305     (setf (cd/flags entry) (file/flags header))
306     (setf (cd/method entry) (file/method header))
307     (setf (cd/time entry) (file/time header))
308     (setf (cd/date entry) (file/date header))
309     (setf (cd/crc entry) (file/crc header))
310     (setf (cd/compressed-size entry) (file/compressed-size header))
311     (setf (cd/size entry) (file/size header))
312     (setf (cd/name-length entry) (file/name-length header))
313     (setf (cd/extra-length entry) (file/extra-length header))
314     (setf (cd/comment-length entry) 0)
315     (setf (cd/disc-number entry) 0) ;XXX ?
316     (setf (cd/internal-attributes entry) 0)
317     (setf (cd/external-attributes entry) 0) ;XXX directories
318     (setf (cd/offset entry) (zipwriter-entry-position e))
319     (write-sequence entry s)
320     (write-sequence
321     (string-to-octets (zipwriter-entry-name e)
322     (zipwriter-external-format z))
323     s)))
324     (let ((end (make-end-header)))
325     (setf (end/signature end) #x06054b50)
326     (setf (end/this-disc end) 0) ;?
327     (setf (end/central-directory-disc end) 0) ;?
328     (setf (end/disc-files end) n)
329     (setf (end/total-files end) n)
330     (setf (end/central-directory-size end) (- (file-position s) pos))
331     (setf (end/central-directory-offset end) pos)
332     (setf (end/comment-length end) 0)
333     (write-sequence end s))))
334    
335     (defmethod zipfile-entry-contents ((entry zipfile-entry) &optional stream)
336     (let (#+allegro (excl:*locale* (excl:find-locale :latin1))
337     (s (zipfile-entry-stream entry))
338     header)
339     (file-position s (zipfile-entry-offset entry))
340     (setf header (make-local-header s))
341     (assert (= (file/signature header) #x04034b50))
342     (file-position s (+ (file-position s)
343     (file/name-length header)
344     (file/extra-length header)))
345     (let ((in (make-instance 'truncating-stream
346     :input-handle s
347     :size (zipfile-entry-compressed-size entry)))
348     (outbuf nil)
349     out)
350     (if stream
351     (setf out stream)
352     (setf outbuf (make-byte-array (zipfile-entry-size entry))
353     out (make-buffer-output-stream outbuf)))
354     (ecase (file/method header)
355     (0 (store in out))
356     (8 (inflate in out)))
357     outbuf)))
358    
359     (defmacro with-zipfile ((file pathname &key external-format) &body body)
360     `(let ((,file (open-zipfile ,pathname
361     ,@(when external-format
362     `(:external-format ,external-format)))))
363     (unwind-protect
364     (progn ,@body)
365     (close-zipfile ,file))))
366    
367     (defun make-zipfile-writer
368     (pathname &key (if-exists :error)
369     (external-format
370     #+allegro (excl:find-external-format :default)
371     #-allegro :dummy))
372     (let (#+allegro (excl:*locale* (excl:find-locale :latin1))
373     (c (cons nil nil)))
374     (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     (defun directoryp (pathname)
423     #+allegro (excl:file-directory-p pathname)
424     #-allegro (and (null (pathname-name pathname))
425     (null (pathname-type pathname))))
426    
427     (defun zip (pathname source-directory &key (if-exists :error))
428     (with-output-to-zipfile (zip pathname :if-exists if-exists)
429     (labels ((recurse (d)
430     (dolist (f #+allegro (directory d :directories-are-files nil)
431     #-allegro (directory d))
432     (cond
433     ((directoryp f)
434     (write-zipentry
435     zip
436     (enough-namestring (namestring f) source-directory)
437     (make-concatenated-stream))
438     (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) source-directory)
448     s)))))))
449     (recurse source-directory))))

  ViewVC Help
Powered by ViewVC 1.1.5