zip-cvs

Download

zip-cvs@common-lisp.net

June 2006

1 participants
2 discussions

[zip-cvs] CVS zip
by dlichteblau 10 Jun '06

10 Jun '06

Update of /project/zip/cvsroot/zip In directory clnet:/tmp/cvs-serv10937 Modified Files: zip.lisp Log Message: CLISP workarounds (Klaus Weidner) --- /project/zip/cvsroot/zip/zip.lisp 2006/06/10 13:58:56 1.8 +++ /project/zip/cvsroot/zip/zip.lisp 2006/06/10 14:07:53 1.9 @@ -419,31 +419,48 @@ :element-type '(unsigned-byte 8)) (zipfile-entry-contents entry s))))))) -(defun directoryp (pathname) +(defun %directoryp (pathname) #+allegro (excl:file-directory-p pathname) #+lispworks (lispworks:file-directory-p pathname) - #-(or lispworks allegro) + #+clisp (ignore-errors + (ext:probe-directory + (concatenate 'string (princ-to-string pathname) "/"))) + #-(or lispworks allegro clisp) (and (null (pathname-name pathname)) (null (pathname-type pathname)))) +(defun %directory (d) + #+allegro (directory d :directories-are-files nil) + #+clisp (append (directory (concatenate 'string (princ-to-string d) "/*/")) + (directory (concatenate 'string (princ-to-string d) "/*"))) + #-(or allegro clisp) (directory d)) + +(defun %file-write-date (f) + #+clisp (posix:file-stat-mtime (posix:file-stat f)) + #-clisp (file-write-date f)) + +(defun %pathname-for-directory (f) + #+(or allegro clisp) f + #-(or allegro clisp) (make-pathname :name :wild :type :wild :defaults f)) + +(defun %directory-namestring (d) + #+clisp (directory-namestring + (truename (concatenate 'string (princ-to-string d) "/"))) + #-clisp (directory-namestring d)) + (defun zip (pathname source-directory &key (if-exists :error)) - (let ((base (directory-namestring source-directory))) + (let ((base (%directory-namestring (merge-pathnames 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)) + (dolist (f (%directory d)) (cond - ((directoryp f) + ((%directoryp f) (write-zipentry zip (enough-namestring (namestring f) base) (make-concatenated-stream) - :file-write-date (file-write-date f)) - (recurse #+allegro f - #-allegro (make-pathname - :name :wild - :type :wild - :defaults f))) + :file-write-date (%file-write-date f)) + (recurse (%pathname-for-directory f))) ((or (pathname-name f) (pathname-type f)) (with-open-file (s f :element-type '(unsigned-byte 8)) (write-zipentry

1 0

[zip-cvs] CVS zip
by dlichteblau 10 Jun '06

10 Jun '06

Update of /project/zip/cvsroot/zip In directory clnet:/tmp/cvs-serv9246 Modified Files: README.html package.lisp zip.lisp Log Message: Comment support (Surendra Singhi) clisp buglet (Klaus Weidner) --- /project/zip/cvsroot/zip/README.html 2006/03/19 14:01:09 1.6 +++ /project/zip/cvsroot/zip/README.html 2006/06/10 13:58:56 1.7 @@ -60,12 +60,13 @@ <h2>Recent changes</h2> <p> - 2006-xx-yy: Fixed the gray stream port (including a data - corruption bug that was in CVS for some time). Switched to - flexi-stream external-format functions for portability. Uses - trivial-gray-streams now. Allegro 8.0 fix. Incompatible change: - Don't bind <tt>*locale*</tt> on Allegro anymore. (Thanks to all - patch submitters). + 2006-xx-yy: Fixed the gray stream port, including a data + corruption bug that was in CVS for some time. (Thanks to Kevin + Reid and others.) Switched to flexi-stream external-format + functions for portability. Uses trivial-gray-streams now. + Allegro 8.0 fix (thanks to Edi Weitz). Comment support (thanks + to Surendra Singhi). Incompatible change: Don't bind + <tt>*locale*</tt> on Allegro anymore. <p> </p> 2005-04-05: ACL fixes (thank to Edi Weitz). Lispworks port --- /project/zip/cvsroot/zip/package.lisp 2006/03/19 14:01:09 1.3 +++ /project/zip/cvsroot/zip/package.lisp 2006/06/10 13:58:56 1.4 @@ -10,6 +10,7 @@ #:get-zipfile-entry #:zipfile-entry-name #:zipfile-entry-size + #:zipfile-entry-comment #:do-zipfile-entries #:zipfile-entry-contents #:unzip --- /project/zip/cvsroot/zip/zip.lisp 2006/03/19 14:01:09 1.7 +++ /project/zip/cvsroot/zip/zip.lisp 2006/06/10 13:58:56 1.8 @@ -38,7 +38,9 @@ (setf (elt array (+ offset 3)) (logand newval #xff)) newval) -(defmacro define-record (constructor (&key (length (gensym))) &rest fields) +(defmacro define-record (constructor + (&key (length #-clisp (gensym) #+clisp (gentemp))) + &rest fields) `(progn (defconstant ,length ,(loop @@ -180,7 +182,8 @@ stream offset size - compressed-size) + compressed-size + comment) (defstruct zipwriter stream @@ -196,19 +199,24 @@ (defun read-entry-object (s external-format) (let* ((header (make-directory-entry s)) (name (make-array (cd/name-length header) - :element-type '(unsigned-byte 8)))) + :element-type '(unsigned-byte 8))) + (comment + (when (plusp (cd/comment-length header)) + (make-array (cd/comment-length header) + :element-type '(unsigned-byte 8))))) (assert (= (cd/signature header) #x02014b50)) (read-sequence name s) (setf name (octets-to-string name external-format)) - (prog1 - (make-zipfile-entry :name name - :stream s - :offset (cd/offset header) - :size (cd/size header) - :compressed-size (cd/compressed-size header)) - (file-position s (+ (file-position s) - (cd/extra-length header) - (cd/comment-length header)))))) + (file-position s (+ (file-position s) (cd/extra-length header))) + (when comment + (read-sequence comment s) + (setf comment (octets-to-string comment external-format))) + (make-zipfile-entry :name name + :stream s + :offset (cd/offset header) + :size (cd/size header) + :compressed-size (cd/compressed-size header) + :comment comment))) (defun open-zipfile (pathname &key (external-format (default-external-format)))

1 0