-
-
Notifications
You must be signed in to change notification settings - Fork 8
/
zippy.lisp
150 lines (137 loc) · 7.22 KB
/
zippy.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
(in-package #:org.shirakumo.zippy)
(defclass zip-file ()
((entries :initarg :entries :initform (make-array 0 :adjustable T :fill-pointer T) :accessor entries)
(disks :initarg :disks :initform NIL :accessor disks)
(comment :initform NIL :initarg :comment :accessor comment)))
(defmethod close ((file zip-file) &key abort)
(when (disks file)
(loop for disk across (disks file)
do (when (streamp disk)
(close disk :abort abort)))
(setf (disks file) NIL)))
(defmethod print-object ((file zip-file) stream)
(let ((disk (when (disks file) (aref (disks file) (1- (length (disks file)))))))
(print-unreadable-object (file stream :type T)
(etypecase disk
(stream (if (open-stream-p disk)
(format stream "~s" (pathname disk))
(format stream "CLOSED")))
(vector-input (format stream "[VECTOR]"))
(null (format stream "CLOSED"))))))
(defun move-in-memory (file)
(when (disks file)
(loop for i from 0 below (length (disks file))
for disk = (aref (disks file) i)
do (when (streamp disk)
(unless (open-stream-p disk)
(error 'stream-closed))
(file-position disk 0)
(let ((buffer (make-array (file-length disk) :element-type '(unsigned-byte 8))))
(read-sequence buffer disk)
(setf (aref (disks file) i) (make-vector-input buffer 0 0 (length buffer)))
(close disk))))))
(defclass zip-entry ()
((zip-file :initarg :zip-file :initform NIL :accessor zip-file)
(crc-32 :initform NIL :accessor crc-32)
(disk :initform NIL :accessor disk)
(offset :initform NIL :accessor offset)
(size :initform NIL :accessor size)
(uncompressed-size :initform NIL :accessor uncompressed-size)
(extra-fields :initform NIL :accessor extra-fields)
(version :initform NIL :initarg :version :accessor version)
(attributes :initform NIL :initarg :attributes :accessor attributes)
(encryption-method :initform NIL :initarg :encryption-method :accessor encryption-method)
(compression-method :initform NIL :initarg :compression-method :accessor compression-method)
(last-modified :initform (get-universal-time) :initarg :last-modified :accessor last-modified)
(file-name :initform NIL :initarg :file-name :accessor file-name)
(comment :initform NIL :initarg :comment :accessor comment)
(content :initform NIL :initarg :content :accessor content)))
(defmethod print-object ((entry zip-entry) stream)
(print-unreadable-object (entry stream :type T)
(format stream "~s" (file-name entry))))
(defun entry-to-file (path entry &key (if-exists :error) password (restore-attributes T))
(with-open-file (stream path :direction :output
:element-type '(unsigned-byte 8)
:if-exists if-exists)
(flet ((output (buffer start end)
(write-sequence buffer stream :start start :end end)
end))
(decode-entry #'output entry :password password)))
(when (and restore-attributes
(eql *compatibility* (second (attributes entry))))
;; TODO: restore other extended attributes from the extra blocks (uid/gid/etc)
(setf (file-attributes:attributes path) (third (attributes entry)))))
(defun entry-to-stream (stream entry &key password)
(flet ((output (buffer start end)
(write-sequence buffer stream :start start :end end)
end))
(decode-entry #'output entry :password password)))
(defun entry-to-vector (entry &key vector (start 0) password)
(let ((vector (etypecase vector
((vector (unsigned-byte 8)) vector)
(null (make-array (uncompressed-size entry) :element-type '(unsigned-byte 8)))))
(i start))
(flet ((fast-copy (buffer start end)
#+sbcl
(sb-sys:with-pinned-objects (vector buffer)
(sb-kernel:system-area-ub8-copy (sb-sys:vector-sap buffer) start (sb-sys:vector-sap vector) i (- end start))
(incf i (- end start))
end))
(slow-copy (buffer start end)
(loop for j from start below end
do (setf (aref vector i) (aref buffer j))
(incf i))
end))
(if #+sbcl (typep vector 'sb-kernel:simple-unboxed-array)
#-sbcl NIL
(decode-entry #'fast-copy entry :password password)
(decode-entry #'slow-copy entry :password password))
vector)))
;; Early define
(defmacro with-zip-file ((file input &key (start 0) end) &body body)
`(call-with-input-zip-file (lambda (,file) ,@body) ,input :start ,start :end ,end))
(defun extract-zip (file path &key (if-exists :error) password)
(etypecase file
(zip-file
(loop for entry across (entries file)
for full-path = (merge-pathnames (pathname-utils:parse-native-namestring (file-name entry)) path)
do (ensure-directories-exist full-path)
(unless (getf (first (attributes entry)) :directory)
(entry-to-file full-path entry :if-exists if-exists :password password))))
(T
(with-zip-file (zip file)
(extract-zip zip path :if-exists if-exists)))))
(defun ensure-zip-file (file &key (strip-root NIL))
(etypecase file
((or pathname string list)
(let ((entries (make-array 0 :adjustable T :fill-pointer T)))
(flet ((process-file (file)
(cond ((wild-pathname-p file)
(dolist (path (directory file))
(vector-push-extend (make-instance 'zip-entry :content path :file-name (enough-namestring path file)) entries)))
((or (pathname-name file) (pathname-type file))
(vector-push-extend (make-instance 'zip-entry :content file) entries))
(T
(setf file (org.shirakumo.filesystem-utils:resolve-symbolic-links file))
(loop with base = (truename (if strip-root file (pathname-utils:parent file)))
for path in (directory (merge-pathnames (merge-pathnames pathname-utils:*wild-file* pathname-utils:*wild-inferiors*)
file))
for file-name = (enough-namestring path base)
do (vector-push-extend (make-instance 'zip-entry :content path :file-name file-name) entries))))))
(if (listp file)
(mapc #'process-file file)
(process-file file)))
(make-instance 'zip-file :entries entries :comment "Created with Zippy")))
((or vector stream)
(let ((entries (make-array 1)))
(setf (aref entries 0) (make-instance 'zip-entry :content file :file-name "-"))
(make-instance 'zip-file :entries entries :comment "Created with Zippy")))
(zip-file
file)))
(defun compress-zip (file target &key (start 0) end (if-exists :error) strip-root password)
(let ((file (ensure-zip-file file :strip-root strip-root)))
(when password
(loop for entry across (entries file)
do (setf (encryption-method entry) :pkware)))
(with-io (io target :direction :output :if-exists if-exists :start start :end end)
(encode-file file io :password password))))