[zip-cvs] CVS update: zip/gray.lisp zip/lispworks.lisp zip/LICENSE zip/README.html zip/acl.lisp zip/package.lisp zip/sbcl.lisp zip/zip.asd zip/zip.lisp
David Lichteblau
dlichteblau at common-lisp.net
Tue Apr 5 15:04:35 UTC 2005
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 at 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)))))
More information about the Zip-cvs
mailing list