[zip-devel] clisp port of "zip" library
Klaus Weidner
kw at w-m-p.com
Wed Aug 24 22:46:18 UTC 2005
Hello,
this patch makes the "zip" library work for CLISP on Linux and Windows -
very lightly tested but it works for me.
I had to modify the define-record macro, CLISP didn't like using a gensym
as a defconstant name.
-Klaus
diff -r -uN ../xfer/zip.tgz.content.13334/clisp.lisp zip/clisp.lisp
--- ../xfer/zip.tgz.content.13334/clisp.lisp 1969-12-31 18:00:00.000000000 -0600
+++ zip/clisp.lisp 2005-08-24 15:52:43.000000000 -0500
@@ -0,0 +1,25 @@
+(in-package :zip)
+
+;;;; FIXME
+
+(defun default-external-format ()
+ :dummy)
+
+(defun octets-to-string (octets ef)
+ (declare (ignore ef))
+ (let* ((m (length octets))
+ (n (cond
+ ((zerop m) 0)
+ ((zerop (elt octets (1- m))) (1- m))
+ (t m)))
+ (result (make-string n)))
+ (map-into result #'code-char octets)
+ result))
+
+(defun string-to-octets (string ef)
+ (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))
diff -r -uN ../xfer/zip.tgz.content.13334/gray.lisp zip/gray.lisp
--- ../xfer/zip.tgz.content.13334/gray.lisp 2005-04-05 10:45:02.000000000 -0500
+++ zip/gray.lisp 2005-08-24 17:19:40.000000000 -0500
@@ -4,11 +4,16 @@
((buf :initarg :buf :accessor buf)
(pos :initform 0 :accessor pos)))
-(defmethod stream-write-sequence
+#+clisp
+(defmethod stream-element-type ((stream buffer-output-stream))
+ '(unsigned-byte 8))
+
+(defmethod #+clisp stream-write-byte-sequence #-clisp stream-write-sequence
#+sbcl ((stream buffer-output-stream) seq &optional (start 0) end)
#+lispworks ((stream buffer-output-stream) seq start end)
- #-(or sbcl lispworks) ...
- (replace (buf stream)
+ #+clisp ((stream buffer-output-stream) seq &optional (start 0) end no-hang unknown)
+ #-(or sbcl lispworks clisp) ...
+ (replace (buf stream) seq
:start1 (pos stream)
:start2 start
:end2 end))
@@ -28,10 +33,11 @@
(incf (pos s)))
nil))
-(defmethod stream-read-sequence
+(defmethod #+clisp stream-read-byte-sequence #-clisp stream-read-sequence
#+sbcl ((s truncating-stream) seq &optional (start 0) (end (length seq)))
#+lispworks ((s truncating-stream) seq start end)
- #-(or sbcl lispworks) ...
+ #+clisp ((s truncating-stream) seq &optional (start 0) (end (length seq)) no-hang unknown)
+ #-(or sbcl lispworks clisp) ...
(let* ((n (- end start))
(max (- (size s) (pos s)))
(result
diff -r -uN ../xfer/zip.tgz.content.13334/package.lisp zip/package.lisp
--- ../xfer/zip.tgz.content.13334/package.lisp 2005-04-05 10:43:11.000000000 -0500
+++ zip/package.lisp 2005-08-24 16:08:08.000000000 -0500
@@ -26,9 +26,17 @@
#-allegro
(:import-from #+sbcl :sb-gray
#+lispworks :stream
- #-(or sbcl lispworks) ...
+ #+clisp :gray
+ #-(or sbcl lispworks clisp) ...
+
#:fundamental-binary-output-stream
+ #-clisp
#:stream-write-sequence
+ #+clisp
+ #:stream-write-byte-sequence
#:fundamental-binary-input-stream
#:stream-read-byte
- #:stream-read-sequence))
+ #-clisp
+ #:stream-read-sequence
+ #+clisp
+ #:stream-read-byte-sequence))
diff -r -uN ../xfer/zip.tgz.content.13334/zip.asd zip/zip.asd
--- ../xfer/zip.tgz.content.13334/zip.asd 2005-04-05 10:43:11.000000000 -0500
+++ zip/zip.asd 2005-08-24 15:47:54.000000000 -0500
@@ -19,7 +19,8 @@
#+sbcl "sbcl"
#+allegro "acl"
#+lispworks "lispworks"
- #-(or sbcl allegro lispworks)
+ #+clisp "clisp"
+ #-(or sbcl allegro lispworks clisp)
#.(error "unsupported lisp")
:depends-on ("package" #-allegro "gray"))
(:file "ifstar" :depends-on ("package"))
diff -r -uN ../xfer/zip.tgz.content.13334/zip.lisp zip/zip.lisp
--- ../xfer/zip.tgz.content.13334/zip.lisp 2005-04-05 14:31:30.000000000 -0500
+++ zip/zip.lisp 2005-08-24 17:10:08.000000000 -0500
@@ -37,29 +37,29 @@
(setf (elt array (+ offset 3)) (logand newval #xff))
newval)
-(defmacro define-record (constructor (&key (length (gensym))) &rest fields)
- `(progn
- (defconstant ,length
- ,(loop
- for (nil type) in fields
- sum (ecase type (:int 4) (:short 2))))
- (defun ,constructor (&optional s)
- (let ((bytes (make-byte-array ,length)))
- (when s
- (read-sequence bytes s))
- bytes))
- ,@(loop
- for (name type) in fields
- for offset = 0 then (+ offset length)
- for length = (ecase type (:int 4) (:short 2))
- for reader = (ecase type (:int 'get-int) (:short 'get-short))
- unless (eq name :dummy)
- append `((defun ,name (r)
- (,reader r ,offset))
- (defun (setf ,name) (newval r)
- (setf (,reader r ,offset) newval))))))
+(defmacro define-record (constructor (&key length-constant) &rest fields)
+ (let ((length (loop
+ for (nil type) in fields
+ sum (ecase type (:int 4) (:short 2)))))
+ `(progn
+ ,@(when length-constant `((defconstant ,length-constant ,length)))
+ (defun ,constructor (&optional s)
+ (let ((bytes (make-byte-array ,length)))
+ (when s
+ (read-sequence bytes s))
+ bytes))
+ ,@(loop
+ for (name type) in fields
+ for offset = 0 then (+ offset length)
+ for length = (ecase type (:int 4) (:short 2))
+ for reader = (ecase type (:int 'get-int) (:short 'get-short))
+ unless (eq name :dummy)
+ append `((defun ,name (r)
+ (,reader r ,offset))
+ (defun (setf ,name) (newval r)
+ (setf (,reader r ,offset) newval)))))))
-(define-record make-end-header (:length +end-header-length+)
+(define-record make-end-header (:length-constant +end-header-length+)
(end/signature :int)
(end/this-disc :short)
(end/central-directory-disc :short)
@@ -418,25 +418,30 @@
(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 zip (pathname source-directory &key (if-exists :error))
- (let ((base (directory-namestring source-directory)))
+ (let ((base #+clisp (directory-namestring (truename (concatenate 'string (princ-to-string source-directory) "/")))
+ #-clisp (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))
+ #+clisp (nconc (directory (concatenate 'string (princ-to-string d) "/*/"))
+ (directory (concatenate 'string (princ-to-string d) "/*")))
+ #-(or allegro clisp) (directory d))
(cond
((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
+ :file-write-date #+clisp (posix:file-stat-mtime (posix:file-stat f))
+ #-clisp (file-write-date f))
+ (recurse #+(or allegro clisp) f
+ #-(or allegro clisp) (make-pathname
:name :wild
:type :wild
:defaults f)))
More information about the zip-devel
mailing list