Update of /project/zip/cvsroot/zip In directory common-lisp.net:/tmp/cvs-serv5309
Modified Files: LICENSE README.html acl.lisp package.lisp sbcl.lisp zip.asd zip.lisp Added Files: gray.lisp lispworks.lisp Log Message: merged Lispworks patch, thanks to Sean Ross
Date: Tue Apr 5 17:04:33 2005 Author: dlichteblau
Index: zip/LICENSE diff -u zip/LICENSE:1.1 zip/LICENSE:1.2 --- zip/LICENSE:1.1 Sun Apr 3 22:38:19 2005 +++ zip/LICENSE Tue Apr 5 17:04:33 2005 @@ -3,6 +3,7 @@
zip.lisp, sbcl.lisp, acl.lisp Copyright (c) 2004,2005 David Lichteblau david@lichteblau.com + Lizenz: (L)LGPL COMPRESS function taken from Zachary Beane's salza. Changes copyright (c) 2004 knowledgeTools Int. GmbH
Index: zip/README.html diff -u zip/README.html:1.1 zip/README.html:1.2 --- zip/README.html:1.1 Sun Apr 3 22:38:19 2005 +++ zip/README.html Tue Apr 5 17:04:33 2005 @@ -63,12 +63,13 @@
<h2>Portability</h2> <p> - Needs gray streams. Currently works out-of-the-box on SBCL and ACL. - Should be trivial to port to other Lisps. + Needs gray streams. Currently works out-of-the-box on SBCL, + Lispworks, and ACL. Should be trivial to port to other Lisps. </p> <p> - Handles Unicode characters in filenames on ACL (within the zip-file), is - waiting for someone to fix Unicode handling on SBCL. + Handles Unicode characters in filenames on ACL and Lispworks + (within the zip-file), is waiting for someone to fix Unicode + handling on SBCL. </p>
<h2>ZIP-file reading</h2>
Index: zip/acl.lisp diff -u zip/acl.lisp:1.2 zip/acl.lisp:1.3 --- zip/acl.lisp:1.2 Tue Apr 5 16:04:01 2005 +++ zip/acl.lisp Tue Apr 5 17:04:33 2005 @@ -1,5 +1,8 @@ (in-package :zip)
+(defun default-external-format () + (excl:find-external-format :default)) + (defun octets-to-string (octets ef) (excl:octets-to-string octets :external-format ef))
Index: zip/package.lisp diff -u zip/package.lisp:1.1.1.1 zip/package.lisp:1.2 --- zip/package.lisp:1.1.1.1 Sun Apr 3 21:36:28 2005 +++ zip/package.lisp Tue Apr 5 17:04:33 2005 @@ -22,4 +22,13 @@ #:skip-gzip-header
#:compress ;deflate.lisp - #:store)) + #:store) + #-allegro + (:import-from #+sbcl :sb-gray + #+lispworks :stream + #-(or sbcl lispworks) ... + #:fundamental-binary-output-stream + #:stream-write-sequence + #:fundamental-binary-input-stream + #:stream-read-byte + #:stream-read-sequence))
Index: zip/sbcl.lisp diff -u zip/sbcl.lisp:1.2 zip/sbcl.lisp:1.3 --- zip/sbcl.lisp:1.2 Sun Apr 3 22:41:37 2005 +++ zip/sbcl.lisp Tue Apr 5 17:04:33 2005 @@ -1,7 +1,12 @@ (in-package :zip)
+;;;; FIXME + +(defun default-external-format () + :dummy) + (defun octets-to-string (octets ef) - (declare (ignore ef)) ;fixme + (declare (ignore ef)) (let* ((m (length octets)) (n (cond ((zerop m) 0) @@ -12,47 +17,9 @@ result))
(defun string-to-octets (string ef) - (declare (ignore ef)) ;fixme + (declare (ignore ef)) (let ((result (make-array (1+ (length string)) :element-type '(unsigned-byte 8) :initial-element 0))) (map-into result #'char-code string) - result)) - -(defclass buffer-output-stream (sb-gray:fundamental-binary-output-stream) - ((buf :initarg :buf :accessor buf) - (pos :initform 0 :accessor pos))) - -(defmethod sb-gray:stream-write-sequence - ((stream buffer-output-stream) seq &optional (start 0) end) - (replace (buf stream) - :start1 (pos stream) - :start2 start - :end2 end)) - -(defun make-buffer-output-stream (outbuf) - (make-instance 'buffer-output-stream :buf outbuf)) - -(defclass truncating-stream (sb-gray:fundamental-binary-input-stream) - ((input-handle :initarg :input-handle :accessor input-handle) - (size :initarg :size :accessor size) - (pos :initform 0 :accessor pos))) - -(defmethod sb-gray:stream-read-byte ((s truncating-stream)) - (if (< (pos s) (size s)) - (prog1 - (read-byte (input-handle s)) - (incf (pos s))) - nil)) - -(defmethod sb-gray:stream-read-sequence - ((s truncating-stream) seq &optional (start 0) (end (length seq))) - (let* ((n (- end start)) - (max (- (size s) (pos s))) - (result - (read-sequence (input-handle s) - seq - :start start - :end (+ start (min n max))))) - (incf (pos s) (- result start)) result))
Index: zip/zip.asd diff -u zip/zip.asd:1.1.1.1 zip/zip.asd:1.2 --- zip/zip.asd:1.1.1.1 Sun Apr 3 21:36:28 2005 +++ zip/zip.asd Tue Apr 5 17:04:33 2005 @@ -11,14 +11,17 @@
(defsystem :zip :default-component-class silent-source-file - :depends-on (:salza #+sbcl :sb-simple-streams) + :depends-on (:salza) :components ((:file "package") + #-allegro (:file "gray" :depends-on ("package")) (:file dependent :pathname #+sbcl "sbcl" #+allegro "acl" - #-(or sbcl allegro) #.(error "unsupported lisp") - :depends-on ("package")) + #+lispworks "lispworks" + #-(or sbcl allegro lispworks) + #.(error "unsupported lisp") + :depends-on ("package" #-allegro "gray")) (:file "ifstar" :depends-on ("package")) (:file "inflate" :depends-on ("package" "ifstar")) (:file "zip" :depends-on ("inflate" dependent))))
Index: zip/zip.lisp diff -u zip/zip.lisp:1.3 zip/zip.lisp:1.4 --- zip/zip.lisp:1.3 Tue Apr 5 16:04:30 2005 +++ zip/zip.lisp Tue Apr 5 17:04:33 2005 @@ -210,9 +210,7 @@ (cd/comment-length header))))))
(defun open-zipfile - (pathname &key (external-format - #+allegro (excl:find-external-format :default) - #-allegro :dummy)) + (pathname &key (external-format (default-external-format))) (let* (#+allegro (excl:*locale* (excl:find-locale :latin1)) (s (open pathname :element-type '(unsigned-byte 8)))) (unwind-protect @@ -359,9 +357,7 @@
(defun make-zipfile-writer (pathname &key (if-exists :error) - (external-format - #+allegro (excl:find-external-format :default) - #-allegro :dummy)) + (external-format (default-external-format))) (let (#+allegro (excl:*locale* (excl:find-locale :latin1)) (c (cons nil nil))) (make-zipwriter @@ -414,29 +410,32 @@
(defun directoryp (pathname) #+allegro (excl:file-directory-p pathname) - #-allegro (and (null (pathname-name pathname)) - (null (pathname-type pathname)))) + #+lispworks (lispworks:file-directory-p pathname) + #-(or lispworks allegro) + (and (null (pathname-name pathname)) + (null (pathname-type pathname))))
(defun zip (pathname source-directory &key (if-exists :error)) - (with-output-to-zipfile (zip pathname :if-exists if-exists) - (labels ((recurse (d) - (dolist (f #+allegro (directory d :directories-are-files nil) - #-allegro (directory d)) - (cond - ((directoryp f) - (write-zipentry - zip - (enough-namestring (namestring f) source-directory) - (make-concatenated-stream)) - (recurse #+allegro f - #-allegro (make-pathname - :name :wild - :type :wild - :defaults f))) - ((or (pathname-name f) (pathname-type f)) - (with-open-file (s f :element-type '(unsigned-byte 8)) + (let ((base (directory-namestring source-directory))) + (with-output-to-zipfile (zip pathname :if-exists if-exists) + (labels ((recurse (d) + (dolist (f #+allegro (directory d :directories-are-files nil) + #-allegro (directory d)) + (cond + ((directoryp f) (write-zipentry zip - (enough-namestring (namestring f) source-directory) - s))))))) - (recurse source-directory)))) + (enough-namestring (namestring f) base) + (make-concatenated-stream)) + (recurse #+allegro f + #-allegro (make-pathname + :name :wild + :type :wild + :defaults f))) + ((or (pathname-name f) (pathname-type f)) + (with-open-file (s f :element-type '(unsigned-byte 8)) + (write-zipentry + zip + (enough-namestring (namestring f) base) + s))))))) + (recurse source-directory)))))