Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
zip memo
(deftype octet () '(unsigned-byte 8))
(defun read-le-uint (size in)
(loop FOR i FROM 0 BELOW size
SUM (ash (read-byte in) (* i 8))))
(defun read-bytes (size in)
(let ((ary (make-array size :element-type 'octet)))
(read-sequence ary in)
ary))
(defstruct local-file-header
signature
version
flags
compression-method
last-modified-time
last-modified-date
crc32
compressed-size
original-size
filename
extended-field)
(defstruct central-directory-file-header
created-version
required-version
flags
compression-method
last-modified-time
last-modified-date
crc32
compressed-size
original-size
start-disk-number
internal-file-attr
external-file-attr
local-file-header-offset
filename
extended-field
file-comment
)
(defstruct central-directory-end
dick-count
start-central-disk-number
central-directory-record-count
total-central-directory-record-count
central-directory-size
central-directory-offset
zip-file-comment)
(defun read-local-file-header (in)
(let* ((version (read-le-uint 2 in))
(flags (read-le-uint 2 in))
(compression-method (read-le-uint 2 in))
(last-modified-time (read-le-uint 2 in))
(last-modified-date (read-le-uint 2 in))
(crc32 (read-le-uint 4 in))
(compressed-size (read-le-uint 4 in))
(original-size (read-le-uint 4 in))
(filename-length (read-le-uint 2 in))
(extended-field-length (read-le-uint 2 in))
(filename (read-bytes filename-length in))
(extended-field (read-bytes extended-field-length in))
)
(make-local-file-header
:signature (coerce #(80 75 3 4) 'octets)
:version version
:flags flags
:compression-method compression-method
:last-modified-time last-modified-time
:last-modified-date last-modified-date
:crc32 crc32
:compressed-size compressed-size
:original-size original-size
:filename filename
:extended-field extended-field)))
(defun read-central-directory-file-header (in)
(let* ((created-version (read-le-uint 2 in))
(required-version (read-le-uint 2 in))
(flags (read-le-uint 2 in))
(compression-method (read-le-uint 2 in))
(last-modified-time (read-le-uint 2 in))
(last-modified-date (read-le-uint 2 in))
(crc32 (read-le-uint 4 in))
(compressed-size (read-le-uint 4 in))
(original-size (read-le-uint 4 in))
(filename-length (read-le-uint 2 in))
(extended-field-length (read-le-uint 2 in))
(file-comment-length (read-le-uint 2 in))
(start-disk-number (read-le-uint 2 in))
(internal-file-attr (read-le-uint 2 in))
(external-file-attr (read-le-uint 4 in))
(local-file-header-offset (read-le-uint 4 in))
(filename (read-bytes filename-length in))
(extended-field (read-bytes extended-field-length in))
(file-comment (read-bytes file-comment-length in)))
(make-central-directory-file-header
:created-version created-version
:required-version required-version
:flags flags
:compression-method compression-method
:last-modified-time last-modified-time
:last-modified-date last-modified-date
:crc32 crc32
:compressed-size compressed-size
:original-size original-size
:start-disk-number start-disk-number
:internal-file-attr internal-file-attr
:external-file-attr external-file-attr
:local-file-header-offset local-file-header-offset
:filename filename
:extended-field extended-field
:file-comment file-comment)))
(defun read-central-directory-end (in)
(let* ((dick-count (read-le-uint 2 in))
(start-central-disk-number (read-le-uint 2 in))
(central-directory-record-count (read-le-uint 2 in))
(total-central-directory-record-count (read-le-uint 2 in))
(central-directory-size (read-le-uint 4 in))
(central-directory-offset (read-le-uint 4 in))
(zip-file-comment-size (read-le-uint 2 in))
(zip-file-comment (read-bytes zip-file-comment-size in)))
(make-central-directory-end
:dick-count dick-count
:start-central-disk-number start-central-disk-number
:central-directory-record-count central-directory-record-count
:total-central-directory-record-count total-central-directory-record-count
:central-directory-size central-directory-size
:central-directory-offset central-directory-offset
:zip-file-comment zip-file-comment)))
(defun read-header (in)
(let ((signature (read-bytes 4 in)))
(cond ((equalp signature #(80 75 3 4))
(read-local-file-header in))
((equalp signature #(80 75 1 2))
(read-central-directory-file-header in))
((equalp signature #(80 75 5 6))
(read-central-directory-end in))
((equalp signature #(0 0 0 0))
nil) ; XXX: eos
(t
(error "unknown signature: ~a" signature)))))
(with-open-file (in "/path/to/file.zip"
:element-type 'octet)
(loop FOR header = (read-header in)
WHILE header
DO
(etypecase header
(local-file-header (print header)
(read-bytes (local-file-header-compressed-size header) in))
(central-directory-file-header (print header))
(central-directory-end (print header))
)))
))
;; format
;; - http://www.tvg.ne.jp/menyukko/cauldron/dtzipformat.html
;; - http://ja.wikipedia.org/wiki/ZIP_%28%E3%83%95%E3%82%A1%E3%82%A4%E3%83%AB%E3%83%95%E3%82%A9%E3%83%BC%E3%83%9E%E3%83%83%E3%83%88%29
(require :common-utils) ; https://github.com/sile/common-utils
(use-package :common-utils)
(require :deflate) ; https://github.com/sile/yahoo_briefcase
(require :creole)
;; (require :flexi-streams)
(defstruct central-directory-file-header
created-version
required-version
flags
compression-method
last-modified-time
last-modified-date
crc32
compressed-size
original-size
start-disk-number
internal-file-attr
external-file-attr
local-file-header-offset
filename
extended-field
file-comment
)
(defun collect-filepathes (path &aux (path (probe-file path)))
(let ((dir? (and path
(null (pathname-name path))
(null (pathname-type path)))))
(cond ((null path)
'())
((not dir?)
(list path))
(t
(cons path (loop FOR subpath IN (directory (format nil "~a*.*" path))
APPEND (collect-filepathes subpath)))))))
(defun write-uint (out size n) ; little endian
(loop FOR i FROM 0 BELOW size
DO (write-byte (ldb (byte 8 (* i 8)) n) out))
(values))
(defun write-uint1 (out n) (write-uint out 1 n))
(defun write-uint2 (out n) (write-uint out 2 n))
(defun write-uint4 (out n) (write-uint out 4 n))
(defun write-bytes (out bytes)
(write-sequence bytes out)
(values))
(defconstant +VERSION_RAW+ 10)
(defconstant +VERSION_DEFLATE+ 20)
(defconstant +VERSION_ZIP64+ 45)
(defconstant +METHOD_RAW+ 0)
(defconstant +METHOD_DEFLATE+ 8)
(defun write-local-file (out path data)
(let* ((time 0)
(date 0)
(version +VERSION_RAW+)
(method +METHOD_RAW+)
(compressed-data data)
(crc32 (deflate.crc32:crc compressed-data))
(name (creole:string-to-octets (subseq (s path) (length *root-path*))
:external-format :sjis))
(extra-field #())
(offset (file-position out)))
(write-bytes out #(80 75 3 4)) ; signature of local-file-header
(write-uint2 out version) ; version
(write-uint2 out 0) ; flags
(write-uint2 out method) ; compression method
(write-uint2 out time) ; last modified time
(write-uint2 out date) ; last modified date
(write-uint4 out crc32) ; crc32
(write-uint4 out (length compressed-data))
(write-uint4 out (length data))
(write-uint2 out (length name))
(write-uint2 out (length extra-field))
(write-bytes out name)
(write-bytes out extra-field)
(write-bytes out compressed-data)
(make-central-directory-file-header
:created-version +VERSION_DEFLATE+
:required-version version
:flags 0
:compression-method method
:last-modified-time time
:last-modified-date date
:crc32 crc32
:compressed-size (length compressed-data)
:original-size (length data)
:start-disk-number 0
:internal-file-attr 0 ; binary data
:external-file-attr 0 ; XXX:
:local-file-header-offset offset
:filename name
:external-file-attr extra-field
:file-comment #())))
(defun write-files (out filepathes)
(loop FOR path IN filepathes
FOR dir? = (and (null (pathname-name path))
(null (pathname-type path)))
FOR data = (if dir? (coerce '() 'octets) (read-binary-file path))
COLLECT
(write-local-file out path data)))
(defun write-central-directory-header (out header)
(with-slots (created-version required-version flags
compression-method last-modified-time last-modified-date
crc32 compressed-size original-size start-disk-number
internal-file-attr external-file-attr local-file-header-offset
filename extended-field file-comment) header
(write-bytes out #(80 75 1 2)) ; signature
(write-uint2 out created-version)
(write-uint2 out required-version)
(write-uint2 out flags)
(write-uint2 out compression-method)
(write-uint2 out last-modified-time)
(write-uint2 out last-modified-date)
(write-uint4 out crc32)
(write-uint4 out compressed-size)
(write-uint4 out original-size)
(write-uint2 out (length filename))
(write-uint2 out (length extended-field))
(write-uint2 out (length file-comment))
(write-uint2 out start-disk-number)
(write-uint2 out internal-file-attr)
(write-uint4 out external-file-attr)
(write-uint4 out local-file-header-offset)
(write-bytes out filename)
(write-bytes out extended-field)
(write-bytes out file-comment)))
(defun write-end-of-central-directory (out offset total-size count)
(write-bytes out #(80 75 5 6)) ; signature
(write-uint2 out 0) ; number of this disk
(write-uint2 out 0) ;
(write-uint2 out count) ; central directory count in this disk
(write-uint2 out count) ; total central directory count
(write-uint4 out total-size) ; size of the central directory
(write-uint4 out offset)
(write-uint4 out 0) ; comment length
(write-bytes out '())) ; comment
(defun write-central-directory-headers (out file-headers)
(loop WITH offset = (file-position out)
FOR header IN file-headers
DO
(write-central-directory-header out header)
FINALLY
(let ((total-size (- (file-position out) offset)))
(write-end-of-central-directory out offset total-size (length file-headers)))))
(defvar *root-path*)
(defun make-zip-file (input-path zip-filename)
(let* ((*root-path* (format nil "/~{~a~^/~}" (butlast (cdr (pathname-directory (probe-file input-path))))))
(filepathes (collect-filepathes input-path)))
(with-open-file (out zip-filename
:direction :output
:if-exists :supersede
:element-type 'octet)
(let ((file-headers
(write-files out filepathes)))
(write-central-directory-headers out file-headers))))
t)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment